C     ******************************************************************
C
C     AESOP IS THE MAIN PROGRAM.  AESOP CALLS SUBROUTINES AES100,
C     AES200, AES300, AES400, AES500, AES600, AES700, AES800,
C     AES900, AND THE PLOTTING SUBROUTINES.
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-S,U-Z)
      LOGICAL  FL34, WHEN
      REAL*8  TSFTR, TT, TS2, ICONST, NN, KC, KE, KFF, KCTOT
      REAL*4  XLEG, YLEG, YLEGM, YLEGA
      COMMON /ABETC/ A(50,50), B(50,5), C(50,50), D(50,15), H(5,50),
     * QC(50,50), NN(50,5), PCINV(5,5), QQ(50,50), RRINV(5,5),
     * DOUT(50,5), CSP(5,50)
      COMMON /COM1/ ADBLE(2500), EX1(50,50), EX2(50,50), EX3(50,50),
     * EX4(50), EXT(100,100), KC(5,50), AMBKC(50,50), ANR(50), ANI(50),
     * EIGR(50), EIGI(50), X(100,100), EIGCLR(50), EIGCLI(50), TS2(100),
     * AR(100), AI(100), XR(100,100), TT(100,100), AAA1(100,100),
     * CR(100), CI(100), S(50,50), SS(50,50), SSS(50,50), FREQ(500),
     * AMP(500), PHASE(500), AMP1(500), PHA1(500), AMP2(500), PHA2(500),
     * AMP3(500), PHA3(500), AMPSTR(1000), PHASTR(1000), SETAP(500),
     * ABKCEH(50,50), KE(50,5), PP(50,50), KFF(5,5), AMPSP(5), AMPSR(5),
     * AMPICX(50), EX13(50,5), EX23(5,50), EX33(5,5), EX5(50,5),
     * EX6(5,50), EX7(5,5), IBL(100), IA(100), IB(100), LEX(100),
     * MEX(100), IC(100), MSROLX(5,50), MSROLY(5,50), MSPY(5,50),
     * MSPYSP(5,5), MSPU(5,5), MICOLX(50,50), MICOLY(50,50),
     * MICCLX(50,50), MICCLY(50,50), MICCLU(50,5)
      COMMON /COM2/ EXX1(50,50), EXX3(50,50), EXX5(50,5), SSSX(50,50)
      COMMON /COM3/ ATOT(100,100), CTOT(50,100), DTOT(100,15),
     * KCTOT(5,100), HTOT(5,100), XOLD(100), XNEW(100)
      COMMON /COM4/ ADBLET(5000), EXTOT1(100,100), SSSTOT(100,100),
     * STOT(100,100), AAA2(100,100), EXTOT4(100), EIGRT(100),
     * EIGIT(100)
      COMMON /COM5/ DXM1(50,50), DXV1(50), DXV2(50), DXV3(50),
     * DNCOF(50), DDCOF(50)
      COMMON /COM6/ DXMT1(100,100), DXVT1(100), DXVT2(100), DXVT3(100),
     * DDCOFT(100), DNCOFT(100)
      COMMON /COM6A/ XX(50,50), YY(50,50), ZZ(5,5), UU(5,5)
      COMMON /COM7/ TTITL(15)
      COMMON /COM8/ OLEV(50,50), EX8(50,50,5), EX9(50,5,5), EXT1(50,5),
     * EXT2(5,50), FL34
      COMMON /PLTLEG/ TRUN(4), TDAT(5)
      COMMON /LEGEND/ XLEG(6), YLEGM(6), YLEGA(6), NX, NYM, NYA
      COMMON /TITLES/ T1(15), T2(15), TNUM(50), T3(15), T4(15), T5(15),
     *T6(15), T7(15), T8(15), T9(15), T10(15), TB1(15), TB2(15), TB3(15)
      COMMON /TRTIT/ TTIT1(12), TTIT2(12), TTIT3(12), TTIT4(12),
     * TTIT5A(11), TTIT5B(11), TTIT5C(11), TUU(4), TXX(4), TYY(4),
     * TYSPD(4), TYSP(4)
      COMMON /ERRS/ IER
      COMMON /DIMS/  N, NM, NC, ND, NO, NTOT
      COMMON /DIMS2/  NMAX, NMMAX, NCMAX, NDMAX, NOMAX, NTOTMX
      COMMON /PRTOP/ IUNIT
      COMMON /NORMS/ SCX(50), SCU(5), SCY(50), SCZ(5), SCYSP(5)
      COMMON /SPREC/ TYOUT(1000,50), TY13(1000,5), TIME(1000), IONPLT,
     * ITRMXX
      COMMON /REFCOM/ TSFTR, DT, FI, DELF, ZERMAX, IF, ISPACE, IOUT,
     * IMEAS, JINC, JIND, ITRMX, NCURV, LINLOG, IP, NAME(9)
      DIMENSION  IFN(1000), WHEN(450,50), INAME(9)
      NAMELIST /N1/ IFN
      DATA  YES /1HY/
      DATA  INAME / 'YOUR', 'PLOT', 7 * '    ' /
C***********************************************************************
C***********************************************************************
C***********************************************************************
C     DESCRIPTION OF COMMONS, LISTING:  THE NAME OF EACH COMMON, WHAT
C     SUBROUTINES USE THAT COMMON, A DESCRIPTION OF EACH VARIABLE IN
C     THAT COMMON, AND WHAT FUNCTIONS USE THAT VARIABLE.
C***********************************************************************
C     COMMON ABETC - AESOP, AES200, AES300, AES400, AES500, AES600,
C                    AES700, AES800, MATCHG, MATIN, MATRD
C***********************************************************************
C A (NMAX, NMAX)
C                201,202,209,301,302,303,401,402,404,501,504,507,510,
C                601,602,701,702,703,704,801,809,817,818
C                SYSTEM MATRIX
C B (NMAX, NCMAX)
C                201,202,209,301,302,303,403,404,501,504,601,604,701,
C                702,801,817,819,819
C                CONTROL INPUT MATRIX
C C (NOMAX, NMAX)
C                201,202,209,303,403,404,504,510,513,601,602,603,604,
C                702,704,817
C                OUTPUT MATRIX
C D (NMAX, NDMAX)
C                201,202,209,303,404,507,510,513,515,703,704
C                DISTURBANCE INPUT MATRIX
C H (NMMAX, NMAX)
C                201,202,209,302,303,403,404,501,507,701,809,817
C                MEASUREMENT MATRIX
C QC (NMAX, NMAX)
C                201,202,203,209,801
C                STATE WEIGHTING MATRIX
C NN (NMAX, NCMAX)
C                201,202,203,209,801
C                STATE-CONTROL WEIGHTING MATRIX
C PCINV (NCMAX, NCMAX)
C                201,202,203,209,801
C                INVERSE OF CONTROL WEIGHTING MATRIX
C QQ (NMAX, NMAX)
C                201,202,204,209,404,809,817,818
C                POWER SPECTRAL DENSITY MATRIX OF PLANT DISTURBANCE
C RRINV (NMMAX, NMMAX)
C                201,202,204,209,404,809
C                INVERSE OF POWER SPECTRAL DENSITY MATRIX OF
C                MEASUREMENT NOISE
C DOUT (NOMAX, NCMAX)
C                201,202,209,303,404,504,510,513,601,603,604,702,817
C                FEED FORWARD MATRIX
C CSP (NCMAX, NMAX)
C                201,202,209,404,604,819
C                SET-POINT OUTPUT MATRIX
C***********************************************************************
C     COMMON COM1 - AESOP, AES100, AES200, AES300, AES400, AES500,
C                   AES600, AES700, AES800, MATIN, MATRD
C***********************************************************************
C ADBLE (NMAX * NMAX)
C                403,801,809,819
C                TEMP VECTOR
C EX1 (NMAX, NMAX)
C                401,601,602,603,604,701,702,703,704,705,803,804,805,
C                806,807,811,813,814,815,817,818
C                1) TEMP MATRIX, 2) MATRIX EXP(A*DT), 3) MODIFIED
C                EIGENVECTOR MATRIX, 4) RESIDUAL ERROR MATRIX, AND
C                5) LYPAUNOV ERROR MATRIX
C EX2 (NMAX, NMAX)
C                402,403,501,504,507,510,513,515,523,601,602,603,604,
C                701,702,703,704,705,804,818
C                1) TEMP MATRIX, 2) MATRIX OF MODESHAPE IN MAGNITUDE
C                AND PHASE ANGLE FORM, 3) INVERSE OF MATRIX OLEV,
C                4) MATRIX A*TSFTR, 5) INTEGRAL OF MATRIX EXP(A*DT),
C                AND 6) RESIDUAL LYAPUNOV MATRIX
C EX3 (NMAX, NMAX)
C                402,804,817,818,819
C                1) TEMP MATRIX, 2) LYAPUNOV EQUATION MATRIX,
C                AND 3) MATRIX A-B*KC
C EX4 (NMAX)
C                401,601,602,603,604,701,702,703,704,705,803,805,811,
C                813,817
C                1) TEMP VECTOR, AND 2) VECTOR OF DIAGONAL ELEMENTS OF
C                DIAGONAL SCALING MATRIX
C EXT (NTOTMX, NTOTMX)
C                801,809
C                TEMP MATRIX
C KC (NCMAX, NMAX)
C                205,301,302,303,405,515,523,603,604,705,801,802,817,818
C                CONTROL GAIN MATRIX
C AMBKC (NMAX, NMAX)
C                301,302,303,513,515,603,604,803,804,818,819
C                MATRIX A-B*KC
C ANR (NMAX)
C                402,601,604,701,702,703,704,705,804,811
C                1) TEMP VECTOR, AND 2) VECTOR OF REAL PARTS OF
C                EIGENVALUES
C ANI (NMAX)
C                402,701,702,703,704,705,804,811
C                1) TEMP VECTOR, AND 2) VECTOR OF IMAGINARY PARTS OF
C                EIGENVALUES
C EIGR (NMAX)
C                401,402,403,805,813
C                VECTOR OF REAL PARTS OF EIGENVALUES
C EIGI (NMAX)
C                401,402,403,805,813
C                VECTOR OF IMAGINARY PARTS OF EIGENVALUES
C X (NTOTMX, NTOTMX)
C                801,809
C                MODIFIED EIGENVECTOR MATRIX OF HAMILTONIAN MATRIX
C EIGCLR (NMAX)
C                803,804
C                VECTOR OF REAL PARTS OF EIGENVALUES OF CLOSED LOOP LQR
C EIGCLI (NMAX)
C                803,804
C                VECTOR OF IMAGINARY PARTS OF EIGENVALUES OF CLOSED
C                LOOP LQR
C TS2 (NTOTMX)
C                801,809
C                SCALING TRANSFORMATION VECTOR OF HAMILTONIAN MATRIX
C AR (NTOTMX)
C                501,504,507,510,513,515,517,519,521,523,801,809
C                1) TEMP VECTOR, AND 2) VECTOR OF JINTH ROW OF THE
C                MATRIX B*TSFTR
C AI (NTOTMX)
C                501,504,507,510,513,515,517,519,521,523,801,809
C                1) TEMP VECTOR, AND 2) VECTOR OF IOUTH COLUMN OF THE
C                MATRIX H
C XR (NTOTMX, NTOTMX)
C                801,809
C                TEMP MATRIX
C TT (NTOTMX, NTOTMX)
C                517,519,521,801,809
C                1) TEMP MATRIX, AND 2) MATRIX ATOT*TSFTR
C AAA1 (NTOTMX, NTOTMX)
C                801,807
C                HAMILTONIAN MATRIX FOR LQR RICCATI EQUATION
C CR (NTOTMX)
C                801,809
C                VECTOR OF REAL PARTS OF EIGENVALUES OF THE
C                HAMILTONIAN MATRIX
C CI (NTOTMX)
C                801,809
C                VECTOR OF IMAGINARY PARTS OF EIGENVALUES OF THE
C                HAMILTONIAN MATRIX
C S (NMAX, NMAX)
C                401,701,702,703,704,705,803,805,811,813,819
C                1) TEMP MATRIX, AND 2) REDUCED AND SCALED FORM OF THE
C                MATRIX A
C SS (NMAX, NMAX)
C                207,801,805,806,807,808
C                RICCATI SOLUTION MATRIX FOR LINEAR QUADRATIC REGULATOR
C SSS (NMAX, NMAX)
C                401,601,602,603,701,702,703,704,705,803,805,811,813,818
C                1) TEMP MATRIX, AND 2) MATRIX C
C FREQ (500)
C                501,502,503,504,505,506,507,508,509,510,511,512,513,
C                514,515,516,517,518,519,520,521,522,523,524,525
C                FREQUENCY VECTOR
C AMP (500)
C                501,502,503,504,505,506,507,508,509,510,511,512,513,
C                515,516,517,519,521,522,523,524,525
C                AMPLITUDE VECTOR
C PHASE (500)
C                501,502,503,504,505,506,507,508,509,510,511,512,513,
C                515,516,517,519,521,522,523,524,525
C                PHASE ANGLE VECTOR
C AMP1 (500)
C                502,505,508,510,511,514,516,520,522,524
C                AMPLITUDE VECTOR
C PHA1 (500)
C                502,505,508,510,511,514,516,520,522,524
C                PHASE ANGLE VECTOR
C AMP2 (500)
C                513,514,517,518,519,520
C                AMPLITUDE VECTOR
C PHA2 (500)
C                513,514,517,518,519,520
C                PHASE ANGLE VECTOR
C AMP3 (500)
C                507,518
C                AMPLITUDE VECTOR
C PHA3 (500)
C                507,518
C                PHASE ANGLE VECTOR
C AMPSTR (1000)
C                502,505,508,511,514,516,518,520,522,524
C                STORAGE VECTOR FOR TWO SETS OF AMPLITUDE
C PHASTR (1000)
C                502,505,508,511,514,516,518,520,522,524
C                STORAGE VECTOR FOR TWO SETS OF PHASE ANGLE
C SETAP (500)
C                502,505,508,511,514,516,518,520,522,524
C                TEMP VECTOR
C ABKCEH (NMAX, NMAX)
C                302,523,705,811
C                MATRIX A-B*KC-KE*H
C KE (NMAX, NMMAX)
C                206,302,303,405,523,705,809,810
C                KALMAN FILTER GAIN MATRIX
C PP (NMAX, NMAX)
C                208,405,809,813,814,815,816,817,818
C                KALMAN FILTER ERROR COVARIANCE MATRIX
C KFF (NCMAX, NCMAX)
C                405,604,819
C                FEED FORWARD GAIN MATRIX FOR NON-ZERO SET POINT
C                REGULATOR
C AMPSP (NCMAX)
C                101,201,202,604
C                VECTOR OF INPUT STEP AMPLITUDES FOR CLOSED LOOP SYSTEM
C AMPSR (NCMAX)
C                101,201,202,601
C                VECTOR OF INPUT STEP AMPLITUDES FOR OPEN LOOP SYSTEM
C AMPICX (NMAX)
C                101,201,202,602,603
C                VECTOR OF INITIAL CONDITION AMPLITUDES
C EX13 (NMAX, NCMAX)
C                403,603,604
C                1) CONTROL EFFECTIVENESS MATRIX,
C                AND 2) SYSTEM INPUT MATRIX FOR NON-ZERO SET POINT
C                REGULATOR
C EX23 (NCMAX, NMAX)
C                604
C                SYSTEM OUTPUT MATRIX FOR NON-ZERO SET POINT REGULATOR
C EX33 (NCMAX, NCMAX)
C                604
C                SYSTEM INPUT-OUTPUT FEEDTHRU MATRIX FOR NON-ZERO SET
C                POINT REGULATOR
C EX5 (NMAX, NCMAX)
C                403,601
C                1) MATRIX OLEV INVERSE *B, AND 2) MATRIX DOUT
C EX6 (NMMAX, NMAX)
C                403
C                OBSERVABILITY MATRIX
C EX7 (NMMAX, NCMAX)
C                403
C                TEMP MATRIX
C IBL (NTOTMX)
C                401,701,702,703,704,705,803,805,811,812,813
C                INTEGER, TEMP VECTOR
C IA (NTOTMX)
C                401,701,702,703,704,705,803,805,811,812,813
C                INTEGER, TEMP VECTOR
C IB (NTOTMX)
C                401,701,702,703,704,705,803,805,811,812,813
C                INTEGER, TEMP VECTOR
C LEX (NTOTMX)
C                401,402,403,601,602,603,604,701,702,703,704,705,801,
C                803,804,805,809,811,812,813,819
C                INTEGER, 1) TEMP VECTOR, AND 2) BLOCK-DIAGONALIZING
C                PERMUTATION VECTOR
C MEX (NTOTMX)
C                401,402,403,701,702,703,704,705,801,803,804,805,809,
C                811,812,813,819
C                INTEGER, 1) TEMP VECTOR, AND 2) VECTOR OF SIZES OF EACH
C                IRREDUCIBLE BLOCK
C IC (NTOTMX)
C                401,701,702,703,704,705,803,805,811,812,813
C                INTEGER, TEMP VECTOR
C MSROLX (NCMAX, NMAX)
C                101,201,202,601
C                INTEGER, INPUT-OUTPUT, OPEN-LOOP, STEP RESPONSE
C                SELECTION MATRIX FOR STATES
C MSROLY (NCMAX, NOMAX)
C                101,201,202,601
C                INTEGER, INPUT-OUTPUT, OPEN-LOOP, STEP RESPONSE
C                SELECTION MATRIX FOR OUTPUTS
C MSPY (NCMAX, NOMAX)
C                101,201,202,604
C                INTEGER, INPUT-OUTPUT, CLOSED-LOOP, STEP RESPONSE
C                SELECTION MATRIX FOR OUTPUTS; STATE FEEDBACK
C MSPYSP (NCMAX, NCMAX)
C                101,201,202,604
C                INTEGER, INPUT-OUTPUT, CLOSED-LOOP, STEP RESPONSE
C                SELECTION MATRIX FOR SET-POINT OUTPUTS; STATE FEEDBACK
C MSPU (NCMAX, NCMAX)
C                101,201,202,604
C                INTEGER, INPUT-OUTPUT, CLOSED-LOOP, STEP RESPONSE
C                SELECTION MATRIX FOR CONTROLS; STATE FEEDBACK
C MICOLX (NMAX, NMAX)
C                101,201,202,602
C                INTEGER, INPUT-OUTPUT, OPEN-LOOP, INITIAL-CONDITION
C                RESPONSE SELECTION MATRIX FOR STATES; STATE FEEDBACK
C MICOLY (NMAX, NOMAX)
C                101,201,202,602
C                INTEGER, INPUT-OUTPUT, OPEN-LOOP, INITIAL-CONDITION
C                RESPONSE SELECTION MATRIX FOR OUTPUTS; STATE FEEDBACK
C MICCLX (NMAX, NMAX)
C                101,201,202,603
C                INTEGER, INPUT-OUTPUT, CLOSED-LOOP, INITIAL-CONDITION
C                RESPONSE SELECTION MATRIX FOR STATES; STATE FEEDBACK
C MICCLY (NMAX, NOMAX)
C                101,201,202,603
C                INTEGER, INPUT-OUTPUT, CLOSED-LOOP, INITIAL-CONDITION
C                RESPONSE SELECTION MATRIX FOR OUTPUTS; STATE FEEDBACK
C MICCLU (NMAX, NCMAX)
C                101,201,202,603
C                INTEGER, INPUT-OUTPUT, CLOSED-LOOP, INITIAL-CONDITION
C                RESPONSE SELECTION MATRIX FOR CONTROLS; STATE FEEDBACK
C***********************************************************************
C     COMMON COM2 - AESOP, AES400, AES600
C***********************************************************************
C EXX1 (NOMAX, NMAX)
C                403
C                OBSERVABILITY MATRIX IN MAGNITUDE AND PHASE ANGLE FORM
C EXX3 (NOMAX, NMAX)
C                403
C                OBSERVABILITY MATRIX
C EXX5 (NOMAX, NCMAX)
C                601,604
C                MATRIX DOUT
C SSSX (NOMAX, NMAX)
C                601,602,603,604
C                MATRIX C
C***********************************************************************
C     COMMON COM3 - AESOP, AES300, AES500, AES600, AES800
C***********************************************************************
C ATOT (NTOTMX, NTOTMX)
C                303,517,519,521,812
C                SYSTEM MATRIX FOR COMBINED REGULATOR-KALMAN FILTER
C                SYSTEM
C CTOT (NOMAX, NTOTMX)
C                303,519
C                OUTPUT MATRIX FOR COMBINED REGULATOR-KALMAN FILTER
C                SYSTEM
C DTOT (NTOTMX, NDMAX)
C                303,517,519,521
C                DISTURBANCE INPUT MATRIX FOR COMBINED REGULATOR-KALMAN
C                FILTER SYSTEM
C KCTOT (NCMAX, NTOTMX)
C                303,521
C                CONTROL GAIN MATRIX FOR COMBINED REGULATOR-KALMAN
C                FILTER SYSTEM
C HTOT (NMMAX, NTOTMX)
C                303,517
C                MEASUREMENT MATRIX FOR COMBINED REGULATOR-KALMAN FILTER
C                SYSTEM
C XOLD (NTOTMX)
C                601,602,603,604
C                TEMP VECTOR
C XNEW (NTOTMX)
C                601,602,603,604
C                TEMP VECTOR
C***********************************************************************
C     COMMON COM4 - AESOP, AES800
C***********************************************************************
C ADBLET (2 * NMAX * NMAX)
C                818
C                TEMP VECTOR
C EXTOT1 (NTOTMX, NTOTMX)
C                812
C                TEMP MATRIX
C SSSTOT (NTOTMX, NTOTMX)
C                812
C                TEMP MATRIX
C STOT (NTOTMX, NTOTMX)
C                812
C                REDUCED AND SCALED FORM OF MATRIX ATOT
C AAA2 (NTOTMX, NTOTMX)
C                809,815
C                HAMILTONIAN MATRIX FOR KALMAN FILTER RICCATI EQUATION
C EXTOT4 (NTOTMX)
C                812
C                VECTOR OF DIAGONAL ELEMENTS OF DIAGONAL SCALING MATRIX
C                OF COMBINED REGULATOR-KALMAN FILTER SYSTEM
C EIGRT (NTOTMX)
C                812
C                VECTOR OF REAL PARTS OF EIGENVALUES OF COMBINED
C                REGULATOR-KALMAN FILTER SYSTEM
C EIGIT (NTOTMX)
C                812
C                VECTOR OF IMAGINARY PARTS OF EIGENVALUES OF COMBINED
C                REGULATOR-KALMAN FILTER SYSTEM
C***********************************************************************
C     COMMON COM5 - AESOP, AES500
C***********************************************************************
C DXM1 (NMAX, NMAX)
C                501,504,507,510,513,515,523
C                TEMP MATRIX
C DXV1 (NMAX)
C                501,504,507,510,513,515,523
C                TEMP VECTOR
C DXV2 (NMAX)
C                501,504,507,510,513,515,523
C                TEMP VECTOR
C DXV3 (NMAX)
C                501,504,507,510,513,515,523
C                VECTOR OF NUMERATOR COEFFICIENTS
C DNCOF (NMAX)
C                501,504,507,510,513,515,523
C                VECTOR OF NUMERATOR COEFFICIENTS
C DDCOF (NMAX)
C                501,504,507,510,513,515,523
C                VECTOR OF DENOMINATOR COEFFICIENTS
C***********************************************************************
C     COMMON COM6 - AESOP, AES500
C***********************************************************************
C DXMT1 (NTOTMX, NTOTMX)
C                517,519,521
C                TEMP MATRIX
C DXVT1 (NTOTMX)
C                517,519,521
C                TEMP VECTOR
C DXVT2 (NTOTMX)
C                517,519,521
C                TEMP VECTOR
C DXVT3 (NTOTMX)
C                517,519,521
C                VECTOR OF NUMERATOR COEFFICIENTS
C DDCOFT (NTOTMX)
C                517,519,521
C                VECTOR OF DENOMINATOR COEFFIENTS
C DNCOFT (NTOTMX)
C                517,519,521
C                VECTOR OF NUMERATOR COEFFICIENTS
C***********************************************************************
C     COMMON COM6A - AESOP, AES800
C***********************************************************************
C XX (NMAX, NMAX)
C                817,818
C                STATE COVARIANCE MATRIX
C YY (NOMAX, NOMAX)
C                817
C                OUTPUT COVARIANCE MATRIX
C ZZ (NMMAX, NMMAX)
C                817
C                MEASUREMENT COVARIANCE MATRIX
C UU (NCMAX, NCMAX)
C                817
C                CONTROL COVARIANCE MATRIX
C***********************************************************************
C     COMMON COM7 - AESOP, AES500
C***********************************************************************
C TTITL (15)
C                502,505,508,511,514,516,518,520,522,524
C                PLOTTING TITLES
C***********************************************************************
C     COMMON COM8 - AESOP, AES400
C***********************************************************************
C OLEV (NMAX, NMAX)
C                402,403
C                MODIFIED EIGENVECTOR MATRIX OF A
C EX8 (NMAX, NOMAX, NCMAX)
C                403
C                RESIDUE ARRAY FOR OPEN LOOP (A, B, C) SYSTEM
C EX9 (NMAX, NMMAX, NCMAX)
C                403
C                RESIDUE ARRAY FOR OPEN LOOP (A, B, H) SYSTEM
C EXT1 (NOMAX, NCMAX)
C                403
C                TEMP MATRIX
C EXT2 (NMMAX, NMAX)
C                403
C                OBSERVABILITY MATRIX IN MAGNITUDE AND PHASE ANGLE FORM
C FL34
C                404,405
C                LOGICAL SCALAR
C                TRUE, NORMALIZATION VECTOR INFORMATION
C                (NAMELIST NRMS) HAS ALREADY BEEN READ IN
C                FALSE, NORMALIZATION VECTOR INFORMATION
C                (NAMELIST NRMS) NEEDS TO BE READ IN
C***********************************************************************
C     COMMON PLTLEG - AESOP, BLOCKA, BODE, STP
C***********************************************************************
C TRUN (4)
C                502,505,508,511,514,516,518,520,522,524,601,604
C                PLOTTING TITLES
C TDAT (5)
C                502,505,508,511,514,516,518,520,522,524,601,604
C                PLOTTING TITLES
C***********************************************************************
C     COMMON LEGEND - AESOP, BLOCKA, BODE
C***********************************************************************
C XLEG (6)
C                502,505,508,511,514,516,518,520,522,524
C                PLOTTING TITLES
C YLEGM (6)
C                502,505,508,511,514,516,518,520,522,524
C                PLOTTING TITLES
C YLEGA (6)
C                502,505,508,511,514,516,518,520,522,524
C                PLOTTING TITLES
C NX
C                502,505,508,511,514,516,518,520,522,524
C                INTEGER, NUMBER OF CHARACTERS IN XLEG
C NYM
C                502,505,508,511,514,516,518,520,522,524
C                INTEGER, NUMBER OF CHARACTERS IN YLEGM
C NYA
C                502,505,508,511,514,516,518,520,522,524
C                INTEGER, NUMBER OF CHARACTERS IN YLEGA
C***********************************************************************
C     COMMON TITLES - AESOP, AES500, BLOCKA, ICRSP, STP
C***********************************************************************
C T1 (15)
C                511
C                PLOTTING TITLES
C T2 (15)
C                516
C                PLOTTING TITLES
C TNUM (50)
C                502,505,508,511,514,516,518,520,522,524,601,602,603,604
C                PLOTTING TITLES
C T3 (15)
C                505
C                PLOTTING TITLES
C T4 (15)
C                524
C                PLOTTING TITLES
C T5 (15)
C                518
C                PLOTTING TITLES
C T6 (15)
C                520
C                PLOTTING TITLES
C T7 (15)
C                522
C                PLOTTING TITLES
C T8 (15)
C                508
C                PLOTTING TITLES
C T9 (15)
C                514
C                PLOTTING TITLES
C T10 (15)
C                502
C                PLOTTING TITLES
C TB1 (15)
C                502,505,508,511
C                PLOTTING TITLES
C TB2 (15)
C                514,516,518,520,522
C                PLOTTING TITLES
C TB3 (15)
C                524
C                PLOTTING TITLES
C***********************************************************************
C     COMMON TRTIT - AESOP, AES600, BLOCKA
C***********************************************************************
C TTIT1 (12)
C                604
C                PLOTTING TITLES
C TTIT2 (12)
C                601
C                PLOTTING TITLES
C TTIT3 (12)
C                603
C                PLOTTING TITLES
C TTIT4 (12)
C                602
C                PLOTTING TITLES
C TTIT5A (11)
C                604
C                PLOTTING TITLES
C TTIT5B (11)
C                601
C                PLOTTING TITLES
C TTIT5C (11)
C                602,603
C                PLOTTING TITLES
C TUU (4)
C                601,603,604
C                PLOTTING TITLES
C TXX (4)
C                601,602,603
C                PLOTTING TITLES
C TYY (4)
C                601,602,603,604
C                PLOTTING TITLES
C TYSPD (4)
C                604
C                PLOTTING TITLES
C TYSP (4)
C                604
C                PLOTTING TITLES
C***********************************************************************
C     COMMON ERRS - AESOP, EIGENT, SCALET
C***********************************************************************
C IER
C                401,701,702,703,704,705,801,803,805,809,811,812,813
C                INTEGER, SET TO ONE IF EITHER NUMERATOR OR DENOMINATOR
C                IN SCALING IS 0
C***********************************************************************
C     COMMON DIMS - AESOP, AES200, AES300, AES400, AES500, AES600,
C                   AES700, AES800, MATCHG, MATIN, MATRD
C***********************************************************************
C N
C                INTEGER, NUMBER OF STATES
C NM
C                INTEGER, NUMBER OF MEASUREMENTS
C NC
C                INTEGER, NUMBER OF CONTROLS
C ND
C                INTEGER, NUMBER OF DISTURBANCES
C NO
C                INTEGER, NUMBER OF OUTPUTS
C NTOT
C                INTEGER, 2 * N
C***********************************************************************
C     COMMON DIMS2 - AESOP, AES200, AES300, AES400, AES500, AES600,
C                    AES700, AES800, MATIN, MATRD
C***********************************************************************
C NMAX
C                INTEGER, MAXIMUM NUMBER OF STATES
C NMMAX
C                INTEGER, MAXIMUM NUMBER OF MEASUREMENTS
C NCMAX
C                INTEGER, MAXIMUM NUMBER OF CONTROLS
C NDMAX
C                INTEGER, MAXIMUM NUMBER OF DISTURBANCES
C NOMAX
C                INTEGER, MAXIMUM NUMBER OF OUTPUTS
C NTOTMX
C                INTEGER, 2 * MAXIMUM NUMBER OF STATES
C***********************************************************************
C     COMMON PRTOP - AESOP, AES200, AES300, AES400, AES600, AES700,
C                    AES800, CONTRL, EGVCTR, ESTMAT, MATIN, MATPRT,
C                    MATRD
C***********************************************************************
C IUNIT
C                201,202,205,206,207,208,209,303,402,403,404,405,601,
C                602,603,604,701,702,703,704,705,801,804,806,807,809,
C                814,815,817,819
C                INTEGER, NUMBER OF PRINT UNIT TO BE USED
C                (2=TERMINAL, 6=PRINTER)
C***********************************************************************
C     COMMON NORMS - AESOP, NRML, UNRML
C***********************************************************************
C SCX (NMAX)
C                404,405
C                VECTOR OF NORMALIZATION FACTORS FOR STATES
C SCU (NCMAX)
C                404,405
C                VECTOR OF NORMALIZATION FACTORS FOR CONTROLS
C SCY (NOMAX)
C                404,405
C                VECTOR OF NORMALIZATION FACTORS FOR OUTPUTS
C SCZ (NMMAX)
C                404,405
C                VECTOR OF NORMALIZATION FACTORS FOR MEASUREMENTS
C SCYSP (NCMAX)
C                404,405
C                VECTOR OF NORMALIZATION FACTORS FOR SET POINT OUTPUTS
C***********************************************************************
C     COMMON SPREC - AESOP, AES500, AES600
C***********************************************************************
C TYOUT (ITRMXX, NOMAX)
C                601,602,603,604
C                MATRIX OF OUTPUT TRANSIENT RESPONSES FOR 1) ONE INPUT
C                STEP, OR 2) ONE INITIAL CONDITION
C TY13 (ITRMXX, NCMAX)
C                604
C                MATRIX OF OUTPUT TRANSIENT RESPONSES FOR NON-ZERO SET
C                POINT REGULATOR
C TIME (ITRMXX)
C                601,602,603,604
C                VECTOR OF TIME POINTS
C IONPLT
C                502,505,508,511,514,516,518,520,522,524,601,602,603,604
C                INTEGER, INDICATES WHETHER ONLINE PLOTS OR NOT
C ITRMXX
C                601,602,603,604
C                INTEGER, MAXIMUM ALLOWABLE VALUE OF THE DESIRED NUMBER
C                OF TIME RESPONSE POINTS (ITRMX)
C***********************************************************************
C     COMMON REFCOM - AESOP, AES100, AES500, AES600, AES700, MATIN,
C                     MATRD
C***********************************************************************
C TSFTR
C                101,201,202,501,504,507,510,513,515,517,519,521,523
C                TIME SCALE FACTOR
C DT
C                101,201,202,601,602,603,604
C                TIME STEP
C FI
C                101,201,202,501,504,507,510,513,515,517,519,521,523
C                INITIAL FREQUENCY
C DELF
C                101,201,202,501,504,507,510,513,515,517,519,521,523
C                SPACING BETWEEN FREQUENCY POINTS
C ZERMAX
C                101,201,202,701,702,703,704,705
C                MAXIMUM EXPECTED VALUE OF TRANSFER FUNCTION ZEROES
C IF
C                101,201,202,501,502,503,504,505,506,507,508,509,510,
C                511,512,513,514,515,516,517,518,519,520,521,522,523,
C                524,525
C                INTEGER, NUMBER OF DESIRED FREQUENCY RESPONSE POINTS
C ISPACE
C                101,201,202,501,504,507,510,513,515,517,519,521,523
C                INTEGER, CONTROLS FREQUENCY OF FREQUENCY RESPONSE
C                PRINTOUTS
C IOUT
C                101,201,202,504,505,510,511,513,514,519,520,702,704
C                INTEGER, INDEX OF OUTPUT
C IMEAS
C                101,201,202,501,502,507,508,517,518,523,524,701,703,705
C                INTEGER, INDEX OF MEASUREMENT
C JINC
C                101,201,202,501,502,504,505,515,516,521,522,523,524,
C                701,702,705
C                INTEGER, INDEX OF CONTROL
C JIND
C                101,201,202,507,508,510,511,513,514,515,516,517,518,
C                519,520,521,522,703,704
C                INTEGER, INDEX OF DISTURBANCE
C ITRMX
C                101,201,202,601,602,603,604
C                INTEGER, NUMBER OF DESIRED TIME RESPONSE POINTS
C NCURV
C                101,201,202,514,518,520
C                INTEGER, CONTROLS CROSS PLOTTING OF FREQUENCY RESPONSES
C LINLOG
C                101,201,202,502,505,508,511,514,516,518,520,522,524
C                INTEGER, INDICATES WHETHER FREQUENCY RESPONSE PLOTS ARE
C                TO BE LINEAR, LOG, OR BOTH
C IP
C                101,201,202,502,505,508,511,514,516,518,520,522,524,
C                601,602,603,604
C                INTEGER, ID OF PLOT ENTITY IN PLOT DATASET
C NAME (9)
C                101,201,202,502,505,508,511,514,516,518,520,522,524,
C                601,602,603,604
C                NAME OF PLOT DATASET
C
C     THE MAXIMUM ALLOWABLE ARRAY DIMENSIONS ARE AS FOLLOWS:
C
      NMAX   = 50
      NMMAX  = 5
      NCMAX  = 5
      NDMAX  = 15
      NOMAX  = 50
      NTOTMX = NMAX + NMAX
      ITRMXX = 1000
C
C
C
 4000 CONTINUE
      DO 4002  I = 1,9
 4002 NAME(I) = INAME(I)
      IONPLT = 0
      CALL GRINIT
      WRITE (2,23)
      READ (2,180)  YON
      IF (YON .NE. YES)  GO TO 4003
      WRITE (2,26)
      READ (2,28)  (NAME(I),  I = 1,2)
      WRITE (2,8235)
      READ (2,180)  YON
      IF (YON .EQ. YES)  IONPLT = 1
      WRITE (2,8238)
      READ (2,8236)  (TDAT(I),  I = 1,5)
      WRITE (2,8239)
      READ (2,8237)  TRUN(4)
 4003 FL34 = .FALSE.
      DO 4001  J = 1,50
      DO 4001  I = 1,450
 4001 WHEN(I,J) = .TRUE.
C
C     SET ALL PREREQUISITES HERE
C
      WHEN(53,2) = .FALSE.
      WHEN(54,2) = .FALSE.
      WHEN(55,2) = .FALSE.
      WHEN(56,2) = .FALSE.
      WHEN(57,2) = .FALSE.
      WHEN(58,2) = .FALSE.
      WHEN(59,2) = .FALSE.
      WHEN(60,2) = .FALSE.
      WHEN(101,2) = .FALSE.
      WHEN(101,3) = .FALSE.
      WHEN(102,2) = .FALSE.
      WHEN(102,3) = .FALSE.
      WHEN(102,4) = .FALSE.
      WHEN(103,2) = .FALSE.
      WHEN(103,3) = .FALSE.
      WHEN(103,4) = .FALSE.
      WHEN(105,7) = .FALSE.
      WHEN(151,2) = .FALSE.
      WHEN(152,2) = .FALSE.
      WHEN(152,11) = .FALSE.
      WHEN(153,12) = .FALSE.
      WHEN(154,2) = .FALSE.
      WHEN(155,10) = .FALSE.
      WHEN(155,13) = .FALSE.
      WHEN(201,2) = .FALSE.
      WHEN(202,14) = .FALSE.
      WHEN(203,14) = .FALSE.
      WHEN(204,2) = .FALSE.
      WHEN(205,15) = .FALSE.
      WHEN(206,15) = .FALSE.
      WHEN(207,2) = .FALSE.
      WHEN(208,16) = .FALSE.
      WHEN(209,16) = .FALSE.
      WHEN(210,2) = .FALSE.
      WHEN(211,17) = .FALSE.
      WHEN(212,17) = .FALSE.
      WHEN(213,7) = .FALSE.
      WHEN(214,17) = .FALSE.
      WHEN(214,18) = .FALSE.
      WHEN(215,7) = .FALSE.
      WHEN(216,19) = .FALSE.
      WHEN(217,9) = .FALSE.
      WHEN(218,16) = .FALSE.
      WHEN(218,20) = .FALSE.
      WHEN(219,9) = .FALSE.
      WHEN(220,17) = .FALSE.
      WHEN(220,21) = .FALSE.
      WHEN(221,9) = .FALSE.
      WHEN(222,22) = .FALSE.
      WHEN(223,8) = .FALSE.
      WHEN(224,23) = .FALSE.
      WHEN(225,23) = .FALSE.
      WHEN(251,2) = .FALSE.
      WHEN(252,2) = .FALSE.
      WHEN(253,7) = .FALSE.
      WHEN(254,2) = .FALSE.
      WHEN(254,3) = .FALSE.
      WHEN(254,7) = .FALSE.
      WHEN(254,28) = .FALSE.
      WHEN(301,2) = .FALSE.
      WHEN(302,2) = .FALSE.
      WHEN(303,2) = .FALSE.
      WHEN(304,2) = .FALSE.
      WHEN(305,8) = .FALSE.
      WHEN(351,2) = .FALSE.
      WHEN(352,3) = .FALSE.
      WHEN(353,7) = .FALSE.
      WHEN(354,2) = .FALSE.
      WHEN(354,25) = .FALSE.
      WHEN(355,5) = .FALSE.
      WHEN(356,5) = .FALSE.
      WHEN(357,24) = .FALSE.
      WHEN(358,24) = .FALSE.
      WHEN(359,2) = .FALSE.
      WHEN(360,4) = .FALSE.
      WHEN(361,8) = .FALSE.
      WHEN(362,9) = .FALSE.
      WHEN(363,6) = .FALSE.
      WHEN(364,6) = .FALSE.
      WHEN(365,26) = .FALSE.
      WHEN(366,26) = .FALSE.
      WHEN(367,2) = .FALSE.
      WHEN(368,27) = .FALSE.
      WHEN(369,7) = .FALSE.
      WHEN(370,28) = .FALSE.
      DO 101  I = 1,NCMAX
      AMPSP(I) = 1.0D0
      AMPSR(I) = 1.0D0
      DO 99  J = 1,NMAX
      MSROLX(I,J) = 1
   99 MICCLU(J,I) = 1
      DO 100  K = 1,NOMAX
      MSPY(I,K) = 1
  100 MSROLY(I,K) = 1
      DO 101  L = 1,NCMAX
      MSPYSP(I,L) = 1
  101 MSPU(I,L)  = 1
      DO 103  I = 1,NMAX
      AMPICX(I) = 1.0D0
      DO 102  J = 1,NOMAX
      MICOLY(I,J) = 1
  102 MICCLY(I,J) = 1
      DO 103  K = 1,NMAX
      MICOLX(I,K) = 1
  103 MICCLX(I,K) = 1
      TSFTR = 1.0D0
      DT = .05D0
      FI = .01D0
      DELF = .02D0
      ZERMAX = 100.0D0
      IF = 49
      ISPACE = 1
      IOUT = 1
      IMEAS = 1
      JINC = 1
      JIND = 1
      ITRMX = 100
      NCURV = 2
      LINLOG = 3
      IP = 0
C
C
C
      IUNIT = 6
      IPRT = 1
      WRITE (2,865)
      READ (2,180)  YON
      IF (YON .EQ. YES)  IPRT=2
      DO 3  I = 1,1000
    3 IFN(I) = 0
      WRITE (2,176)
      READ (2,180)  YON
      IF (YON .EQ. YES)  GO TO 9
      WRITE (2,8008)
      READ (2,N1)
      GO TO 4
    9 WRITE (2,150)
      PAUSE
      REWIND 21
      READ (21,N1)
      DO 226  I = 1,1000
      NFUN = I
      IF (IFN(I) .EQ. 0)  GO TO 227
  226 CONTINUE
  227 WRITE (2,278)
      WRITE (2,279)  (IFN(I),  I = 1,NFUN)
      WRITE (2,280)
    4 CONTINUE
      MZ = 0
C
C
C
    5 MZ = MZ + 1
C
C
C
    6 IF (IFN(MZ) .LT. 999)  GO TO 7
      WRITE (6,181)
      WRITE (6,182)  (IFN(I),  I = 1,MZ)
      CALL TERM
      WRITE (2,177)
      READ (2,180)  YON
      IF (YON .NE. YES)  RETURN
      WRITE (2,152)
      PAUSE
      WRITE (22,N1)
      RETURN
C
C CHECK ON N1 GOES HERE TOO
C
    7 IFUNC = IFN(MZ)
      WRITE (6,8229)  IFUNC
      WRITE (2,8229)  IFUNC
      IF (IFUNC .GT. 100)  GO TO 10
      IF (IFUNC .NE. 0)  GO TO 20
    8 WRITE (2,185)
      DO 30  I = MZ,1000
      READ (2,186)  IFN(I)
      IF (IFN(I) .EQ. 0)  GO TO 6
   30 CONTINUE
   10 IF (IFUNC .GE. 101 .AND. IFUNC .LE. 102)  GO TO 11
      IF (IFUNC .GE. 201 .AND. IFUNC .LE. 210)  GO TO 12
      IF (IFUNC .GE. 301 .AND. IFUNC .LE. 303)  GO TO 13
      IF (IFUNC .GE. 401 .AND. IFUNC .LE. 405)  GO TO 14
      IF (IFUNC .GE. 501 .AND. IFUNC .LE. 525)  GO TO 15
      IF (IFUNC .GE. 601 .AND. IFUNC .LE. 604)  GO TO 16
      IF (IFUNC .GE. 701 .AND. IFUNC .LE. 705)  GO TO 17
      IF (IFUNC .GE. 801 .AND. IFUNC .LE. 820)  GO TO 18
      IF (IFUNC .GE. 901 .AND. IFUNC .LE. 904)  GO TO 19
   20 WRITE (2,8230)
      K = MZ - 1
      IF (K .EQ. 0)  GO TO 22
      WRITE (2,182)  (IFN(I),  I = 1,K)
   22 WRITE (2,8220)
      WRITE (2,8223)
      READ (2,180)  YON
      IF (YON .NE. YES)  GO TO 8
      WRITE (2,8221)
      READ (2,186)  IFN(MZ)
      GO TO 6
   11 CALL AES100 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
      IF (IAND .EQ. 1)  GO TO 20
      GO TO 5
   12 CALL AES200 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
      IF (IAND .EQ. 1)  GO TO 20
      GO TO 5
   13 CALL AES300 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
      IF (IAND .EQ. 1)  GO TO 20
      GO TO 5
   14 CALL AES400 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
      IF (IAND .EQ. 1)  GO TO 20
      GO TO 5
   15 CALL AES500 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
      IF (IAND .EQ. 1)  GO TO 20
      GO TO 5
   16 CALL AES600 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
      IF (IAND .EQ. 1)  GO TO 20
      GO TO 5
   17 CALL AES700 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
      IF (IAND .EQ. 1)  GO TO 20
      GO TO 5
   18 CALL AES800 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
      IF (IAND .EQ. 1)  GO TO 20
      GO TO 5
   19 CALL AES900 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
      IF (IAND .EQ. 1)  GO TO 20
      GO TO 5
C
C
C             FORMATS
C
C
   23 FORMAT (1X, 'DO YOU WISH TO MAKE PLOTS, Y OR N?')
   26 FORMAT (1X, 'ENTER THE PLOT NAME  - 8 ALPHANUMERIC CHARACTERS')
   28 FORMAT (2A4)
  150 FORMAT (1X, 'DDEF 21 TO THE N1 DATASET')
  152 FORMAT (1X, 'DDEF NAME OF N1 DATASET TO 22')
  176 FORMAT (1X, 'READ IN N1 FROM STORAGE?')
  177 FORMAT (1X, 'STORE THE N1 FOR THIS RUN?')
  180 FORMAT (A1)
  181 FORMAT (1X, 'THE FUNCTION SEQUENCE USED DURING THIS RUN WAS: ')
  182 FORMAT (20I4)
  185 FORMAT (1X, 'TO COMPUTE FURTHER, ENTER NEXT FUNCTION NOS.(I3), ONE
     * PER LINE', / 1X, 'TO TERMINATE ENTER 999(LAST ENTRY MUST BE A RET
     *URN)')
  186 FORMAT (I3)
  278 FORMAT (2X, '&N1' / 2X, 'IFN = ')
  279 FORMAT (15(1X, I4))
  280 FORMAT (2X, '&END')
  865 FORMAT (1X, 'EXTENDED TERMINAL OUTPUT?')
 8008 FORMAT (1X, 'ENTER NAMELIST DATA AS ''&N1 IFN= , , , &END''' )
 8220 FORMAT (1X, 'THE PRESENT FUNCTION IS NOT A LEGITIMATE ONE,' / 1X,
     *'YOU WILL NOW HAVE A CHANCE TO REPLACE IT WITH ONE GOOD ONE' / 1X,
     * 'OR TO TERMINATE OR TO ENTER A LIST OF FUNCTIONS.')
 8221 FORMAT (1X, 'TYPE IN AN I3 NUMBER TO REPLACE THE CURRENT FUNCTION;
     *' / 1X, 'IF THE NUMBER IS 999, THE PROGRAM WILL TERMINATE.')
 8223 FORMAT (1X, 'TYPE Y TO ENTER ONE REPLACEMENT FUNCTION;' / 1X, 'TYP
     *E N TO ENTER A LIST OF FUNCTIONS.')
 8229 FORMAT (1H0 / 1X, 'FUNCTION ', I4)
 8230 FORMAT (1X, 'THESE ARE THE FUNCTIONS YOU HAVE RUN THUS FAR ')
 8235 FORMAT (1X, 'DO YOU WISH TO MAKE ONLINE PLOTS, Y OR N?')
 8236 FORMAT (5A4)
 8237 FORMAT (A4)
 8238 FORMAT (1X, 'ENTER TODAY''S DATE (LESS THAN OR EQUAL TO 20 CHARACT
     *ERS)')
 8239 FORMAT (1X, 'ENTER THE PARAMETER YOU USED FOR AESRUN')
      END
      SUBROUTINE AES100 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
C
C     ******************************************************************
C
C     SUBROUTINE AES100 CONTAINS THOSE FUNCTIONS WHICH PERFORM PROGRAM
C     CONTROL.  AES100 CALLS SUBROUTINE PREREQ.
C     AES100 IS CALLED BY MAIN PROGRAM AESOP.
C
C     INPUTS:
C
C              IFN     VECTOR OF FUNCTION NUMBERS TO BE DONE (1000)
C              IFUNC   FUNCTION NUMBER
C              MZ      WHICH FUNCTION IS TO BE DONE
C              IPRT    PRINT OPTION:  1, STANDARD PRINT;
C                                     2, EXTENDED PRINT
C              WHEN    LOGICAL MATRIX OF PREREQUISITES (450,50)
C
C     OUTPUTS:
C
C              IAND    DECISION VARIABLE:
C                      0, PREREQUISITES HAVE BEEN DONE;
C                      1, PREREQUISITES HAVE NOT BEEN DONE
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-S,U-Z)
      LOGICAL  WHEN
      REAL*8  TSFTR, TT, TS2, KC, KE, KFF
      COMMON /COM1/ ADBLE(2500), EX1(50,50), EX2(50,50), EX3(50,50),
     * EX4(50), EXT(100,100), KC(5,50), AMBKC(50,50), ANR(50), ANI(50),
     * EIGR(50), EIGI(50), X(100,100), EIGCLR(50), EIGCLI(50), TS2(100),
     * AR(100), AI(100), XR(100,100), TT(100,100), AAA1(100,100),
     * CR(100), CI(100), S(50,50), SS(50,50), SSS(50,50), FREQ(500),
     * AMP(500), PHASE(500), AMP1(500), PHA1(500), AMP2(500), PHA2(500),
     * AMP3(500), PHA3(500), AMPSTR(1000), PHASTR(1000), SETAP(500),
     * ABKCEH(50,50), KE(50,5), PP(50,50), KFF(5,5), AMPSP(5), AMPSR(5),
     * AMPICX(50), EX13(50,5), EX23(5,50), EX33(5,5), EX5(50,5),
     * EX6(5,50), EX7(5,5), IBL(100), IA(100), IB(100), LEX(100),
     * MEX(100), IC(100), MSROLX(5,50), MSROLY(5,50), MSPY(5,50),
     * MSPYSP(5,5), MSPU(5,5), MICOLX(50,50), MICOLY(50,50),
     * MICCLX(50,50), MICCLY(50,50), MICCLU(50,5)
      COMMON /REFCOM/ TSFTR, DT, FI, DELF, ZERMAX, IF, ISPACE, IOUT,
     * IMEAS, JINC, JIND, ITRMX, NCURV, LINLOG, IP, NAME(9)
      DIMENSION  IFN(1000), WHEN(450,50)
      NAMELIST /REFS/ TSFTR, DT, FI, DELF, ZERMAX, AMPSP, AMPSR, AMPICX,
     * IF, ISPACE, IOUT, IMEAS, JINC, JIND, ITRMX, NCURV, LINLOG, MSPY,
     * MSPYSP, MSPU, MSROLY, MSROLX, MICCLY, MICCLX, MICCLU, MICOLY,
     * MICOLX
      DATA YES /1HY/
C
C
C
      IFUNC = IFUNC - 100
      GO TO (9101,9102), IFUNC
C
C     CHANGE REFERENCE VALUES  (REFS)
C
 9101 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 1)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,182)
      WRITE (6,182)
      WRITE (2,90)
      READ (2,100)  YON
      IF (YON .EQ. YES)  WRITE (2,REFS)
   10 WRITE (2,181)
      READ (2,REFS)
      WRITE (2,REFS)
      WRITE (2,120)
      READ (2,100)  YON
      IF (YON .EQ. YES)  GO TO 10
      WRITE (6,REFS)
      RETURN
C
C     PAUSE TO ALLOW USER TO CHANGE DDEFS FOR DATASETS TO BE
C     READ IN OR WRITTEN OUT.
C
 9102 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 2)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,183)
      WRITE (6,183)
      WRITE (2,8801)
      PAUSE
      RETURN
C
C
C             FORMATS
C
C
   90 FORMAT (1X, 'DISPLAY REFS BEFORE MAKING CHANGES?')
  100 FORMAT (A1)
  120 FORMAT (1X, 'ARE THERE ANYMORE CHANGES, Y OR N?')
  181 FORMAT (1X, 'ENTER CHANGES TO NAMELIST REFS (TSFTR, DT, FI, DELF,
     *ZERMAX, AMPSP, AMPSR,' / 1X, 'AMPICX, IF, ISPACE, IOUT, IMEAS, JIN
     *C, JIND, ITRMX, NCURV, LINLOG, MSPY,' / 1X, 'MSPYSP, MSPU, MSROLY,
     * MSROLX, MICCLY, MICCLX, MICCLU, MICOLY, MICOLX)')
  182 FORMAT (1X, 'CHANGES TO REFS' / )
  183 FORMAT (1X, 'CHANGES TO DDEFS' / )
 8801 FORMAT (1X, 'YOU MAY NOW CHANGE YOUR DDEFS IF YOU WISH ' /
     * 1X, 'DONT FORGET TO CLOSE AND RELEASE THE OLD ONES FIRST')
      END
      SUBROUTINE AES200 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
C
C     ******************************************************************
C
C     SUBROUTINE AES200 CONTAINS THOSE FUNCTIONS WHICH INPUT DATA.
C     AES200 CALLS SUBROUTINES MATCHG, MATIN, MATPRT, MATRD, AND PREREQ.
C     AES200 IS CALLED BY MAIN PROGRAM AESOP.
C
C     INPUTS:
C
C              IFN     VECTOR OF FUNCTION NUMBERS TO BE DONE (1000)
C              IFUNC   FUNCTION NUMBER
C              MZ      WHICH FUNCTION IS TO BE DONE
C              IPRT    PRINT OPTION:  1, STANDARD PRINT;
C                                     2, EXTENDED PRINT
C              WHEN    LOGICAL MATRIX OF PREREQUISITES (450,50)
C
C     OUTPUTS:
C
C              IAND    DECISION VARIABLE:
C                      0, PREREQUISITES HAVE BEEN DONE;
C                      1, PREREQUISITES HAVE NOT BEEN DONE
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-S,U-Z)
      LOGICAL  FL34, WHEN
      REAL*8  TSFTR, TT, TS2, KC, KE, KFF, NN
      COMMON /ABETC/ A(50,50), B(50,5), C(50,50), D(50,15), H(5,50),
     * QC(50,50), NN(50,5), PCINV(5,5), QQ(50,50), RRINV(5,5),
     * DOUT(50,5), CSP(5,50)
      COMMON /COM1/ ADBLE(2500), EX1(50,50), EX2(50,50), EX3(50,50),
     * EX4(50), EXT(100,100), KC(5,50), AMBKC(50,50), ANR(50), ANI(50),
     * EIGR(50), EIGI(50), X(100,100), EIGCLR(50), EIGCLI(50), TS2(100),
     * AR(100), AI(100), XR(100,100), TT(100,100), AAA1(100,100),
     * CR(100), CI(100), S(50,50), SS(50,50), SSS(50,50), FREQ(500),
     * AMP(500), PHASE(500), AMP1(500), PHA1(500), AMP2(500), PHA2(500),
     * AMP3(500), PHA3(500), AMPSTR(1000), PHASTR(1000), SETAP(500),
     * ABKCEH(50,50), KE(50,5), PP(50,50), KFF(5,5), AMPSP(5), AMPSR(5),
     * AMPICX(50), EX13(50,5), EX23(5,50), EX33(5,5), EX5(50,5),
     * EX6(5,50), EX7(5,5), IBL(100), IA(100), IB(100), LEX(100),
     * MEX(100), IC(100), MSROLX(5,50), MSROLY(5,50), MSPY(5,50),
     * MSPYSP(5,5), MSPU(5,5), MICOLX(50,50), MICOLY(50,50),
     * MICCLX(50,50), MICCLY(50,50), MICCLU(50,5)
      COMMON /DIMS/  N, NM, NC, ND, NO, NTOT
      COMMON /DIMS2/  NMAX, NMMAX, NCMAX, NDMAX, NOMAX, NTOTMX
      COMMON /PRTOP/ IUNIT
      DIMENSION  IFN(1000), WHEN(450,50)
      NAMELIST /CONPAR/ QC, NN, PCINV
      NAMELIST /ESTPAR/ QQ, RRINV
      DATA YES /1HY/
C
C
C
      IFUNC = IFUNC - 200
      GO TO (9201,9202,9203,9204,9205,9206,9207,9208,9209,9210), IFUNC
C
C     READ SYSTEM MATRICES FOR 3RD ORDER TEST CASE
C
 9201 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 51)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8808)
      WRITE (6,8808)
      IF (IPRT .EQ. 2)  IUNIT = 2
      CALL MATIN
      DO 6001  I = 1,450
 6001 WHEN(I,2) = .TRUE.
      RETURN
C
C     READ MATRICES A, B, C, D, H, DOUT, CSP, QC, NN, PCINV, QQ, AND
C     RRINV AND ALL DIMENSIONS AND REFS (STORED AS NAMELIST 'MATDAT'
C     AND NAMELIST 'REFS') USING UNIT 33.
C
 9202 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 52)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8806)
      WRITE (6,8806)
      CALL MATRD
      DO 6006  I = 1,450
 6006 WHEN(I,2) = .TRUE.
      RETURN
C
C     REVISE WEIGHTING MATRICES QC, NN, AND PCINV (CONPAR)
C
 9203 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 53)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,90)
      READ (2,100)  YON
      IF (YON .EQ. YES)  WRITE (2,CONPAR)
   10 WRITE (2,8232)
      READ (2,CONPAR)
      WRITE (2,CONPAR)
      WRITE (2,120)
      READ (2,100)  YON
      IF (YON .EQ. YES)  GO TO 10
      WRITE (6,CONPAR)
      RETURN
C
C     REVISE NOISE PSD MATRICES QQ AND RRINV (ESTPAR)
C
 9204 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 54)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,95)
      READ (2,100)  YON
      IF (YON .EQ. YES)  WRITE (2,ESTPAR)
   15 WRITE (2,8233)
      READ (2,ESTPAR)
      WRITE (2,ESTPAR)
      WRITE (2,120)
      READ (2,100)  YON
      IF (YON .EQ. YES)  GO TO 15
      WRITE (6,ESTPAR)
      RETURN
C
C     READ CONTROL GAINS FROM A DATASET USING UNIT 08
C
 9205 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 55)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8802)
      WRITE (6,8802)
      REWIND 8
      READ (8)  ((KC(I,J),  I = 1,NC),  J = 1,N)
      WRITE (6,8227)
      CALL MATPRT (KC, NC, N, NCMAX)
      DO 6002  I = 1,450
      WHEN(I,3) = .TRUE.
 6002 WHEN(I,10) = .TRUE.
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,8227)
      CALL MATPRT (KC, NC, N, NCMAX)
      IUNIT = 6
      RETURN
C
C     READ KALMAN FILTER GAINS FROM A DATASET USING UNIT 09
C
 9206 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 56)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8803)
      WRITE (6,8803)
      REWIND 9
      READ (9) ((KE(I,J), I = 1,N), J = 1,NM)
      WRITE (6,8226)
      CALL MATPRT (KE, N, NM, NMAX)
      DO 6003  I = 1,450
      WHEN(I,4) = .TRUE.
 6003 WHEN(I,10) = .TRUE.
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,8226)
      CALL MATPRT (KE, N, NM, NMAX)
      IUNIT = 6
      RETURN
C
C     READ CONTROL RICCATI SOLUTION MATRIX SS FROM A DATASET USING
C     UNIT 16
C
 9207 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 57)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8804)
      WRITE (6,8804)
      REWIND 16
      READ (16)  ((SS(I,J),  I = 1,N),  J = 1,N)
      WRITE (6,8229)
      CALL MATPRT (SS, N, N, NMAX)
      DO 6004  I = 1,450
 6004 WHEN(I,5) = .TRUE.
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,8229)
      CALL MATPRT (SS, N, N, NMAX)
      IUNIT = 6
      RETURN
C
C     READ ERROR COVARIANCE MATRIX PP FROM A DATASET USING UNIT 15
C
 9208 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 58)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8805)
      WRITE (6,8805)
      REWIND 15
      READ (15)  ((PP(I,J),  I = 1,N),  J = 1,N)
      WRITE (6,8228)
      CALL MATPRT (PP, N, N, NMAX)
      DO 6005  I = 1,450
 6005 WHEN(I,6) = .TRUE.
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,8228)
      CALL MATPRT (PP, N, N, NMAX)
      IUNIT = 6
      RETURN
C
C     READ FEED FORWARD MATRIX KFF FROM A DATASET USING UNIT 17
C
 9209 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 59)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8809)
      WRITE (6,8809)
      REWIND 17
      READ (17)  ((KFF(I,J),  I = 1,NC),  J = 1,NC)
      WRITE (6,8230)
      CALL MATPRT (KFF, NC, NC, NCMAX)
      DO 6007  I = 1,450
 6007 WHEN(I,28) = .TRUE.
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,8230)
      CALL MATPRT (KFF, NC, NC, NCMAX)
      IUNIT = 6
      RETURN
C
C     CHANGE MATRICES A, B, C, D, H, DOUT, CSP, QC, NN, PCINV, QQ, AND
C     RRINV AND ANY DIMENSIONS BY READING CHANGES IN AT TERMINAL USING
C     NAMELIST MATDAT.
C
 9210 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 60)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8807)
      WRITE (6,8807)
      CALL MATCHG
      RETURN
C
C
C             FORMATS
C
C
   90 FORMAT (1X, 'DISPLAY CONPAR BEFORE MAKING CHANGES?')
   95 FORMAT (1X, 'DISPLAY ESTPAR BEFORE MAKING CHANGES?')
  100 FORMAT (A1)
  120 FORMAT (1X, 'ARE THERE ANYMORE CHANGES, Y OR N?')
 8226 FORMAT (1X, 'KE = ')
 8227 FORMAT (1X, 'KC = ')
 8228 FORMAT (1X, 'PP = ')
 8229 FORMAT (1X, 'SS = ')
 8230 FORMAT (1X, 'KFF = ')
 8232 FORMAT (1X, 'ENTER CONTROL WTS QC, NN AND/OR PCINV (NAMELIST CONPA
     *R)')
 8233 FORMAT (1X, 'ENTER KALMAN FILTER NOISE MATRICES QQ AND/OR RRINV (N
     *AMELIST ESTPAR)')
 8802 FORMAT (1X, 'READ THE PREVIOUSLY STORED CONTROL GAINS FROM UNIT 08
     *' / )
 8803 FORMAT (1X, 'READ THE PREVIOUSLY STORED KALMAN FILTER GAINS FROM U
     *NIT 09' / )
 8804 FORMAT (1X, 'READ THE PREVIOUSLY STORED CONTROL RICCATI SOLUTION M
     *ATRIX SS FROM UNIT 16' / )
 8805 FORMAT (1X, 'READ THE PREVIOUSLY STORED ERROR COVARIANCE MATRIX PP
     * FROM UNIT 15' / )
 8806 FORMAT (1X, 'READ INPUT DATA -- MATRICES AND REFERENCE VALUES DEFI
     *NED' / 1X, 'IN NAMELISTS ''MATDAT'' AND ''REFS''' / )
 8807 FORMAT (1X, 'CHANGE MATRICES A, B, C, D, H, DOUT, CSP, QC, NN, PCI
     *NV, QQ, OR RRINV AND ANY' / 1X, 'OR ALL DIMENSIONS BY READING CHAN
     *GES IN AT TERMINAL USING NAMELIST ''MATDAT''')
 8808 FORMAT (1X, 'PUT IN THE 3RD ORDER TEST CASE MATRICES BY USING SUBR
     *OUTINE MATIN' / )
 8809 FORMAT (1X, 'READ THE PREVIOUSLY STORED FEED FORWARD MATRIX KFF FR
     *OM UNIT 17' / )
      END
      SUBROUTINE AES300 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
C
C     ******************************************************************
C
C     SUBROUTINE AES300 CONTAINS THOSE FUNCTIONS WHICH FORM MATRICES.
C     AES300 CALLS SUBROUTINES MATPRT AND PREREQ.
C     AES300 IS CALLED BY MAIN PROGRAM AESOP.
C
C     INPUTS:
C
C              IFN     VECTOR OF FUNCTION NUMBERS TO BE DONE (1000)
C              IFUNC   FUNCTION NUMBER
C              MZ      WHICH FUNCTION IS TO BE DONE
C              IPRT    PRINT OPTION:  1, STANDARD PRINT;
C                                     2, EXTENDED PRINT
C              WHEN    LOGICAL MATRIX OF PREREQUISITES (450,50)
C
C     OUTPUTS:
C
C              IAND    DECISION VARIABLE:
C                      0, PREREQUISITES HAVE BEEN DONE;
C                      1, PREREQUISITES HAVE NOT BEEN DONE
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-S,U-Z)
      LOGICAL  WHEN
      REAL*8  TT, TS2, NN, KC, KE, KFF, KCTOT
      COMMON /ABETC/ A(50,50), B(50,5), C(50,50), D(50,15), H(5,50),
     * QC(50,50), NN(50,5), PCINV(5,5), QQ(50,50), RRINV(5,5),
     * DOUT(50,5), CSP(5,50)
      COMMON /COM1/ ADBLE(2500), EX1(50,50), EX2(50,50), EX3(50,50),
     * EX4(50), EXT(100,100), KC(5,50), AMBKC(50,50), ANR(50), ANI(50),
     * EIGR(50), EIGI(50), X(100,100), EIGCLR(50), EIGCLI(50), TS2(100),
     * AR(100), AI(100), XR(100,100), TT(100,100), AAA1(100,100),
     * CR(100), CI(100), S(50,50), SS(50,50), SSS(50,50), FREQ(500),
     * AMP(500), PHASE(500), AMP1(500), PHA1(500), AMP2(500), PHA2(500),
     * AMP3(500), PHA3(500), AMPSTR(1000), PHASTR(1000), SETAP(500),
     * ABKCEH(50,50), KE(50,5), PP(50,50), KFF(5,5), AMPSP(5), AMPSR(5),
     * AMPICX(50), EX13(50,5), EX23(5,50), EX33(5,5), EX5(50,5),
     * EX6(5,50), EX7(5,5), IBL(100), IA(100), IB(100), LEX(100),
     * MEX(100), IC(100), MSROLX(5,50), MSROLY(5,50), MSPY(5,50),
     * MSPYSP(5,5), MSPU(5,5), MICOLX(50,50), MICOLY(50,50),
     * MICCLX(50,50), MICCLY(50,50), MICCLU(50,5)
      COMMON /COM3/ ATOT(100,100), CTOT(50,100), DTOT(100,15),
     * KCTOT(5,100), HTOT(5,100), XOLD(100), XNEW(100)
      COMMON /DIMS/  N, NM, NC, ND, NO, NTOT
      COMMON /DIMS2/  NMAX, NMMAX, NCMAX, NDMAX, NOMAX, NTOTMX
      COMMON /PRTOP/ IUNIT
      DIMENSION  IFN(1000), WHEN(450,50)
C
C
C
      IFUNC = IFUNC - 300
      GO TO (9301,9302,9303), IFUNC
C
C     FORM A - BKC MATRIX
C
 9301 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 101)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8809)
      WRITE (6,8809)
      DO 63  J = 1,N
      DO 63  I = 1,N
      SUM = 0.0D0
      DO 635  K = 1,NC
  635 SUM = SUM + B(I,K) * KC(K,J)
   63 AMBKC(I,J) = A(I,J) - SUM
      WRITE (6,438)
      CALL MATPRT (AMBKC, N, N, NMAX)
      DO 6008  I = 1,450
 6008 WHEN(I,7) = .TRUE.
      RETURN
C
C     FORM A - BKC - KEH MATRIX
C
 9302 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 102)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8810)
      WRITE (6,8810)
      DO 8030  J = 1,N
      DO 8030  I = 1,N
      SUM = 0.0D0
      DO 8020  K = 1,NC
 8020 SUM = SUM + B(I,K) * KC(K,J)
 8030 AMBKC(I,J) = A(I,J) - SUM
      DO 8050  J = 1,N
      DO 8050  I = 1,N
      SUM = 0.0D0
      DO 8040  K = 1,NM
 8040 SUM = SUM + KE(I,K) * H(K,J)
 8050 ABKCEH(I,J) = AMBKC(I,J) - SUM
      WRITE (6,103)
      CALL MATPRT (ABKCEH, N, N, NMAX)
      DO 6009  I = 1,450
 6009 WHEN(I,8) = .TRUE.
      RETURN
C
C     FORM ATOT, CTOT, DTOT, KCTOT, AND HTOT MATRICES WHICH DESCRIBE
C     OPTIMAL CONTROL SYSTEM WITH KALMAN FILTER IN FEEDBACK LOOP
C
 9303 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 103)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8811)
      WRITE (6,8811)
      DO 7055  J = 1,N
      DO 7055  I = 1,N
 7055 ATOT(I,J) = A(I,J)
      DO 7060  J = 1,N
      JJ = J + N
      DO 7060  I = 1,N
      SUM = 0.0D0
      DO 7058  K = 1,NC
 7058 SUM = SUM - B(I,K) * KC(K,J)
 7060 ATOT(I,JJ) = SUM
      DO 7065  J = 1,N
      DO 7065  I = 1,N
      II = I + N
      SUM = 0.0D0
      DO 7064  K = 1,NM
 7064 SUM = SUM + KE(I,K) * H(K,J)
 7065 ATOT(II,J) = SUM
      DO 8031  J = 1,N
      DO 8031  I = 1,N
      SUM = 0.0D0
      DO 8021  K = 1,NC
 8021 SUM = SUM + B(I,K) * KC(K,J)
 8031 AMBKC(I,J) = A(I,J) - SUM
      DO 8051  J = 1,N
      JJ = J + N
      DO 8051  I = 1,N
      II = I + N
      SUM = 0.0D0
      DO 8041  K = 1,NM
 8041 SUM = SUM + KE(I,K) * H(K,J)
 8051 ATOT(II,JJ) = AMBKC(I,J) - SUM
      WRITE (6,105)
      CALL MATPRT (ATOT, NTOT, NTOT, NTOTMX)
      DO 7500  J = 1,NTOT
      DO 7500  I = 1,NO
      CTOT(I,J) = 0.0D0
      IF (J .GT. N)  GO TO 7500
      CTOT(I,J) = C(I,J)
 7500 CONTINUE
      DO 7501  J = 1,N
      JJ = J + N
      DO 7501  I = 1,NO
      DO 7501  K = 1,NC
 7501 CTOT(I,JJ) = CTOT(I,JJ) - DOUT(I,K) * KC(K,J)
      WRITE (6,193)
      CALL MATPRT (CTOT, NO, NTOT, NOMAX)
      DO 7600  J = 1,ND
      DO 7600  I = 1,NTOT
      DTOT(I,J) = 0.0D0
      IF (I .GT. N)  GO TO 7600
      DTOT(I,J) = D(I,J)
 7600 CONTINUE
      WRITE (6,194)
      CALL MATPRT (DTOT, NTOT, ND, NTOTMX)
      DO 7502  J = 1,NTOT
      JJ = J - N
      DO 7502  I = 1,NC
      KCTOT(I,J) = 0.0D0
      IF (J .LE. N)  GO TO 7502
      KCTOT(I,J) = -KC(I,JJ)
 7502 CONTINUE
      WRITE (6,196)
      CALL MATPRT (KCTOT, NC, NTOT, NCMAX)
      DO 7503  J = 1,NTOT
      DO 7503  I = 1,NM
      HTOT(I,J) = 0.0D0
      IF (J .GT. N)  GO TO 7503
      HTOT(I,J) = H(I,J)
 7503 CONTINUE
      WRITE (6,197)
      CALL MATPRT (HTOT, NM, NTOT, NMMAX)
      DO 6010  I = 1,450
 6010 WHEN(I,9) = .TRUE.
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,105)
      CALL MATPRT (ATOT, NTOT, NTOT, NTOTMX)
      WRITE (2,193)
      CALL MATPRT (CTOT, NO, NTOT, NOMAX)
      WRITE (2,194)
      CALL MATPRT (DTOT, NTOT, ND, NTOTMX)
      WRITE (2,196)
      CALL MATPRT (KCTOT, NC, NTOT, NCMAX)
      WRITE (2,197)
      CALL MATPRT (HTOT, NM, NTOT, NMMAX)
      IUNIT = 6
      RETURN
C
C
C             FORMATS
C
C
  103 FORMAT (1X, 'A-BKC-KEH = ')
  105 FORMAT (1X, 'ATOT = ')
  193 FORMAT (1X, 'CTOT = ' )
  194 FORMAT (1X, 'DTOT = ' )
  196 FORMAT (1X, 'KCTOT = ' )
  197 FORMAT (1X, 'HTOT = ' )
  438 FORMAT (1X, 'AMBKC = ')
 8809 FORMAT (1X, 'FORM A-BKC MATRIX' / )
 8810 FORMAT (1X, 'FORM A-BKC-KEH MATRIX' / )
 8811 FORMAT (1X, 'FORM ATOT, CTOT, DTOT, KCTOT, AND HTOT MATRICES' /
     *1X,'FOR OPTIMAL CONTROL SYSTEM WITH KALMAN FILTER IN FEEDBACK LOOP
     *' / )
      END
      SUBROUTINE AES400 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
C
C     ******************************************************************
C
C     SUBROUTINE AES400 CONTAINS THOSE FUNCTIONS WHICH CALCULATE
C     CONTROLLABILITY, OBSERVABILITY, EIGENVALUES, EIGENVECTORS, AND
C     RESIDUES, AND WHICH PERFORM NORMALIZATION AND UN-NORMALIZATION.
C     AES400 CALLS SUBROUTINES CTBL, EGVCTR, EIGEN, MATPRT, MODSHP,
C     NRML, OBSBL, PREREQ, RESI, AND UNRML.
C     AES400 IS CALLED BY MAIN PROGRAM AESOP.
C
C     INPUTS:
C
C              IFN     VECTOR OF FUNCTION NUMBERS TO BE DONE (1000)
C              IFUNC   FUNCTION NUMBER
C              MZ      WHICH FUNCTION IS TO BE DONE
C              IPRT    PRINT OPTION:  1, STANDARD PRINT;
C                                     2, EXTENDED PRINT
C              WHEN    LOGICAL MATRIX OF PREREQUISITES (450,50)
C
C     OUTPUTS:
C
C              IAND    DECISION VARIABLE:
C                      0, PREREQUISITES HAVE BEEN DONE;
C                      1, PREREQUISITES HAVE NOT BEEN DONE
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-S,U-Z)
      LOGICAL  FL34, WHEN
      REAL*8  TT, TS2, NN, KC, KE, KFF
      COMMON /ABETC/ A(50,50), B(50,5), C(50,50), D(50,15), H(5,50),
     * QC(50,50), NN(50,5), PCINV(5,5), QQ(50,50), RRINV(5,5),
     * DOUT(50,5), CSP(5,50)
      COMMON /COM1/ ADBLE(2500), EX1(50,50), EX2(50,50), EX3(50,50),
     * EX4(50), EXT(100,100), KC(5,50), AMBKC(50,50), ANR(50), ANI(50),
     * EIGR(50), EIGI(50), X(100,100), EIGCLR(50), EIGCLI(50), TS2(100),
     * AR(100), AI(100), XR(100,100), TT(100,100), AAA1(100,100),
     * CR(100), CI(100), S(50,50), SS(50,50), SSS(50,50), FREQ(500),
     * AMP(500), PHASE(500), AMP1(500), PHA1(500), AMP2(500), PHA2(500),
     * AMP3(500), PHA3(500), AMPSTR(1000), PHASTR(1000), SETAP(500),
     * ABKCEH(50,50), KE(50,5), PP(50,50), KFF(5,5), AMPSP(5), AMPSR(5),
     * AMPICX(50), EX13(50,5), EX23(5,50), EX33(5,5), EX5(50,5),
     * EX6(5,50), EX7(5,5), IBL(100), IA(100), IB(100), LEX(100),
     * MEX(100), IC(100), MSROLX(5,50), MSROLY(5,50), MSPY(5,50),
     * MSPYSP(5,5), MSPU(5,5), MICOLX(50,50), MICOLY(50,50),
     * MICCLX(50,50), MICCLY(50,50), MICCLU(50,5)
      COMMON /COM2/ EXX1(50,50), EXX3(50,50), EXX5(50,5), SSSX(50,50)
      COMMON /COM8/ OLEV(50,50), EX8(50,50,5), EX9(50,5,5), EXT1(50,5),
     * EXT2(5,50), FL34
      COMMON /DIMS/  N, NM, NC, ND, NO, NTOT
      COMMON /DIMS2/  NMAX, NMMAX, NCMAX, NDMAX, NOMAX, NTOTMX
      COMMON /PRTOP/ IUNIT
      DIMENSION  IFN(1000), WHEN(450,50)
C
C
C
      IFUNC = IFUNC - 400
      GO TO (9401,9402,9403,9404,9405), IFUNC
C
C     COMPUTE OPEN LOOP EIGENVALUES
C
 9401 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 151)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,110)
      WRITE (6,110)
      CALL EIGEN (A, EIGR, EIGI, EX1, SSS, S, IA, IB, LEX, MEX, IBL, IC,
     * EX4, N, NMAX)
      DO 6026  I = 1,450
 6026 WHEN(I,11) = .TRUE.
      RETURN
C
C     OBTAIN OPEN LOOP EIGENVECTORS AND MODE SHAPES
C
 9402 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 152)
      IF (IAND .EQ. 1)  RETURN
      ISEL = 0
      IHALF = 0
      WRITE (2,8207)
      WRITE (6,8207)
      CALL EGVCTR (A, EIGR, EIGI, OLEV, N, EX2, EX3, ANR, ANI, LEX, MEX,
     * 1, NMAX, ISEL, IHALF)
      IF (IPRT .EQ. 1)  GO TO 61
      IUNIT = 2
      WRITE (2,866)
      CALL MATPRT (OLEV, N, N, NMAX)
      IUNIT = 6
   61 CALL MODSHP (OLEV, EX2, EIGI, N, NMAX)
      DO 6018  I = 1,450
 6018 WHEN(I,12) = .TRUE.
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,867)
      CALL MATPRT (EX2, N, N, NMAX)
      IUNIT = 6
      RETURN
C
C     OPEN LOOP SYSTEM ANALYSIS CALCULATIONS
C     (1) CHECK OPEN LOOP SYSTEM CONTROLS EFFECTIVENESS (CONTROLLABILITY
C )
C     (2) CHECK SYSTEM OBSERVABILITY THRU THE H(OBSERVATION) MATRIX
C           AND ALSO THRU THE C(OUTPUT) MATRIX
C     (3) CALCULATE RESIDUES FOR OPEN LOOP SYSTEM (A, B, H)
C           AND ALSO FOR SYSTEM (A, B, C)
C
 9403 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 153)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8817)
      WRITE (6,8817)
      CALL CTBL (B, EIGI, OLEV, EX2, EX13, EX5, ADBLE, LEX, MEX, N, NC,
     * NMAX)
      IF (IPRT .EQ. 1)  GO TO 403
      IUNIT = 2
      WRITE (2,8208)
      CALL MATPRT (EX13, N, NC, NMAX)
      IUNIT = 6
  403 WRITE (2,8209)
      WRITE (6,8209)
      CALL OBSBL (H, OLEV, EIGI, EXT2, EX6, N, NM, NMMAX, NMAX)
      IF (IPRT .EQ. 1)  GO TO 406
      IUNIT =  2
      CALL MATPRT (EXT2, NM, N, NMMAX)
      IUNIT = 6
  406 WRITE (2,8210)
      WRITE (6,8210)
      CALL OBSBL (C, OLEV, EIGI, EXX1, EXX3, N, NO, NOMAX, NMAX)
      IF (IPRT .EQ. 1)  GO TO 407
      IUNIT =  2
      CALL MATPRT (EXX1, NO, N, NOMAX)
      IUNIT = 6
  407 WRITE (2,8818)
      WRITE (6,8818)
      CALL RESI (EX6, EX5, EIGR, EIGI, EX9, EX7, N, NC, NM, NMAX,
     * NMMAX)
      WRITE (2,8819)
      WRITE (6,8819)
      CALL RESI (EXX3, EX5, EIGR, EIGI, EX8, EXT1, N, NC, NO, NMAX,
     * NOMAX)
      RETURN
C
C     NORMALIZE SYSTEM MATRICES A, B, C, H, QQ, RRINV, D, DOUT, AND CSP.
C     NORMALIZING FACTORS ARE READ IN FROM UNIT 34 IF NOT PREVIOUSLY SET
C .
C
 9404 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 154)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8807)
      WRITE (6,8807)
      CALL NRML (A, B, C, H, QQ, RRINV, D, DOUT, CSP, N, NC, NO, NM, ND,
     * NMAX, NCMAX, NOMAX, NMMAX, FL34)
      DO 6007  I = 1,450
 6007 WHEN(I,13) = .TRUE.
      IUNIT = 6
      IF (IPRT .EQ. 2)  IUNIT = 2
  408 WRITE (IUNIT,8690)
      WRITE (IUNIT,504)
      CALL MATPRT (A, N, N, NMAX)
      WRITE (IUNIT,505)
      CALL MATPRT (B, N, NC, NMAX)
      WRITE (IUNIT,511)
      CALL MATPRT (C, NO, N, NOMAX)
      WRITE (IUNIT,512)
      CALL MATPRT (H, NM, N, NMMAX)
      WRITE (IUNIT,513)
      CALL MATPRT (QQ, N, N, NMAX)
      WRITE (IUNIT,514)
      CALL MATPRT (RRINV, NM, NM, NMMAX)
      WRITE (IUNIT,515)
      CALL MATPRT (D, N, ND, NMAX)
      WRITE (IUNIT,8700)
      CALL MATPRT (DOUT, NO, NC, NOMAX)
      WRITE (IUNIT,8701)
      CALL MATPRT (CSP, NC, N, NCMAX)
      IF (IUNIT .EQ. 6)  RETURN
      IUNIT = 6
      GO TO 408
C
C     UN-NORMALIZE MATRICES KC, KE, KFF, AND PP
C     NORMALIZING FACTORS ARE READ IN FROM UNIT 34 IF NOT PREVIOUSLY SET
C .
C
 9405 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 155)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8808)
      WRITE (6,8808)
      CALL UNRML (KC, KE, KFF, PP, NC, NM, N, NCMAX, NMAX, FL34)
      IUNIT = 6
      IF (IPRT .EQ. 2)  IUNIT = 2
  409 WRITE (IUNIT,503)
      WRITE (IUNIT,506)
      CALL MATPRT (KC, NC, N, NCMAX)
      WRITE (IUNIT,507)
      CALL MATPRT (KE, N, NM, NMAX)
      WRITE (IUNIT,508)
      CALL MATPRT (KFF, NC, NC, NCMAX)
      WRITE (IUNIT,509)
      CALL MATPRT (PP, N, N, NMAX)
      IF (IUNIT .EQ. 6)  RETURN
      IUNIT = 6
      GO TO 409
C
C
C             FORMATS
C
C
  110 FORMAT (1X, 'OPEN LOOP SYSTEM EIGENVALUES', /)
  503 FORMAT (1H0 / 1X, 'UNNORMALIZED SYSTEM MATRICES' /)
  504 FORMAT (1X, 'THE A MATRIX IS')
  505 FORMAT (1X, 'THE B MATRIX IS')
  506 FORMAT (1X, 'THE KC MATRIX IS')
  507 FORMAT (1X, 'THE KE MATRIX IS')
  508 FORMAT (1X, 'THE KFF MATRIX IS')
  509 FORMAT (1X, 'THE PP MATRIX IS')
  511 FORMAT (1X, 'THE C MATRIX IS')
  512 FORMAT (1X, 'THE H MATRIX IS')
  513 FORMAT (1X, 'THE QQ MATRIX IS')
  514 FORMAT (1X, 'THE RRINV MATRIX IS')
  515 FORMAT (1X, 'THE D MATRIX IS')
  866 FORMAT (1X, 'MODIFIED EIGENVECTOR MATRIX OF A' )
  867 FORMAT (1X, 'THE MATRIX OF MODE SHAPES IN MAG. AND ANGLE(DEG.) FOR
     *M' )
 8207 FORMAT (1X, 'OPEN LOOP EIGENVECTORS AND MODE SHAPES' )
 8208 FORMAT (1X, 'SYSTEM CONTROLABILITY')
 8209 FORMAT (1X, 'SYSTEM OBSERVABILITY FOR (A AND H)')
 8210 FORMAT (1X, 'SYSTEM OBSERVABILITY FOR (A AND C)')
 8690 FORMAT (1H0 / 1X, 'NORMALIZED SYSTEM MATRICES' /)
 8700 FORMAT (1X, 'THE DOUT MATRIX IS')
 8701 FORMAT (1X, 'THE CSP MATRIX IS')
 8807 FORMAT (1X, 'NORMALIZE SYSTEM MATRICES;' / 1X, 'NORMALIZING FACTOR
     *S ARE READ IN FROM UNIT 34 IF NOT PREVIOUSLY SET' /)
 8808 FORMAT (1X, 'UNNORMALIZE GAINS AND ERROR COVARIANCE MATRIX;' / 1X,
     *'NORMALIZING FACTORS ARE READ IN FROM UNIT 34 IF NOT PREVIOUSLY SE
     *T' / )
 8817 FORMAT (1X, 'OPEN LOOP SYSTEM ANALYSIS CALCULATIONS' / )
 8818 FORMAT (1X, 'RESIDUES FOR (A, B, H) SYSTEM')
 8819 FORMAT (1X, 'RESIDUES FOR (A, B, C) SYSTEM')
      END
      SUBROUTINE AES500 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
C
C     ******************************************************************
C
C     SUBROUTINE AES500 CONTAINS THOSE FUNCTIONS WHICH CALCULATE
C     FREQUENCY RESPONSE AND BODE PLOTS.
C     AES500 CALLS SUBROUTINES BODE, FRSPNS, AND PREREQ.
C     AES500 IS CALLED BY MAIN PROGRAM AESOP.
C
C     INPUTS:
C
C              IFN     VECTOR OF FUNCTION NUMBERS TO BE DONE (1000)
C              IFUNC   FUNCTION NUMBER
C              MZ      WHICH FUNCTION IS TO BE DONE
C              IPRT    PRINT OPTION:  1, STANDARD PRINT;
C                                     2, EXTENDED PRINT
C              WHEN    LOGICAL MATRIX OF PREREQUISITES (450,50)
C
C     OUTPUTS:
C
C              IAND    DECISION VARIABLE:
C                      0, PREREQUISITES HAVE BEEN DONE;
C                      1, PREREQUISITES HAVE NOT BEEN DONE
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-S,U-Z)
      LOGICAL  WHEN
      REAL*8  TSFTR, TT, TS2, NN, KC, KE, KFF, KCTOT
      COMMON /ABETC/ A(50,50), B(50,5), C(50,50), D(50,15), H(5,50),
     * QC(50,50), NN(50,5), PCINV(5,5), QQ(50,50), RRINV(5,5),
     * DOUT(50,5), CSP(5,50)
      COMMON /COM1/ ADBLE(2500), EX1(50,50), EX2(50,50), EX3(50,50),
     * EX4(50), EXT(100,100), KC(5,50), AMBKC(50,50), ANR(50), ANI(50),
     * EIGR(50), EIGI(50), X(100,100), EIGCLR(50), EIGCLI(50), TS2(100),
     * AR(100), AI(100), XR(100,100), TT(100,100), AAA1(100,100),
     * CR(100), CI(100), S(50,50), SS(50,50), SSS(50,50), FREQ(500),
     * AMP(500), PHASE(500), AMP1(500), PHA1(500), AMP2(500), PHA2(500),
     * AMP3(500), PHA3(500), AMPSTR(1000), PHASTR(1000), SETAP(500),
     * ABKCEH(50,50), KE(50,5), PP(50,50), KFF(5,5), AMPSP(5), AMPSR(5),
     * AMPICX(50), EX13(50,5), EX23(5,50), EX33(5,5), EX5(50,5),
     * EX6(5,50), EX7(5,5), IBL(100), IA(100), IB(100), LEX(100),
     * MEX(100), IC(100), MSROLX(5,50), MSROLY(5,50), MSPY(5,50),
     * MSPYSP(5,5), MSPU(5,5), MICOLX(50,50), MICOLY(50,50),
     * MICCLX(50,50), MICCLY(50,50), MICCLU(50,5)
      COMMON /COM3/ ATOT(100,100), CTOT(50,100), DTOT(100,15),
     * KCTOT(5,100), HTOT(5,100), XOLD(100), XNEW(100)
      COMMON /COM5/ DXM1(50,50), DXV1(50), DXV2(50), DXV3(50),
     * DNCOF(50), DDCOF(50)
      COMMON /COM6/ DXMT1(100,100), DXVT1(100), DXVT2(100), DXVT3(100),
     * DDCOFT(100), DNCOFT(100)
      COMMON /COM7/ TTITL(15)
      COMMON /TITLES/ T1(15), T2(15), TNUM(50), T3(15), T4(15), T5(15),
     *T6(15), T7(15), T8(15), T9(15), T10(15), TB1(15), TB2(15), TB3(15)
      COMMON /DIMS/  N, NM, NC, ND, NO, NTOT
      COMMON /DIMS2/  NMAX, NMMAX, NCMAX, NDMAX, NOMAX, NTOTMX
      COMMON /SPREC/ TYOUT(1000,50), TY13(1000,5), TIME(1000), IONPLT,
     * ITRMXX
      COMMON /REFCOM/ TSFTR, DT, FI, DELF, ZERMAX, IF, ISPACE, IOUT,
     * IMEAS, JINC, JIND, ITRMX, NCURV, LINLOG, IP, NAME(9)
      DIMENSION  IFN(1000), WHEN(450,50), TB(15)
C
C
C
      IFUNC = IFUNC - 500
      GO TO (9501,9502,9503,9504,9505,9506,9507,9508,9509,9510,9511,
     * 9512,9513,9514,9515,9516,9517,9518,9519,9520,9521,9522,9523,9524,
     * 9525), IFUNC
C
C     OPEN LOOP FREQUENCY RESPONSE OF MEASUREMENT IMEAS TO CONTROL INPUT
C     JINC
C
 9501 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 201)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,175)  IMEAS, JINC
      WRITE (2,175)  IMEAS, JINC
      DD = 0.0D0
      CALL FRSPNS (A, B, H, DD, IMEAS, JINC, N, TSFTR, DXM1, DXV1,
     * DXV2, DXV3, EX2, AR, AI, NMAX, NMMAX, DDCOF, DNCOF, FI, DELF, IF,
     * FREQ, AMP, PHASE, ISPACE, 1)
      DO 6025  I = 1,450
 6025 WHEN(I,14) = .TRUE.
      RETURN
C
C     PLOT OPEN LOOP FREQUENCY RESPONSE OF MEASUREMENT IMEAS TO CONTROL
C     INPUT JINC
C
 9502 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 202)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8821)
      WRITE (6,8821)
      DO 626  I = 1,15
      TB(I) = TB1(I)
  626 TTITL(I) = T10(I)
      TTITL(5) = TNUM(IMEAS)
      TTITL(10) = TNUM(JINC)
      IF (LINLOG .EQ. 1 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP, AMP1, PHASE, PHA1, TTITL, TB, IF, 1,
     * AMPSTR, PHASTR, SETAP, 4, 4, IP, NAME, IONPLT)
      IF (LINLOG .EQ. 2 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP, AMP1, PHASE, PHA1, TTITL, TB, IF, 1,
     * AMPSTR, PHASTR, SETAP, 3, 2, IP, NAME, IONPLT)
      RETURN
C
C     STORE OPEN LOOP FREQUENCY RESPONSE OF MEASUREMENT IMEAS TO CONTROL
C     INPUT JINC IN A DATASET USING UNIT 10
C
 9503 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 203)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8818)
      WRITE (6,8818)
      WRITE (10,230)  (FREQ(I), AMP(I), PHASE(I),  I = 1,IF)
      RETURN
C
C     OPEN LOOP FREQUENCY RESPONSE OF OUTPUT IOUT TO CONTROL INPUT JINC
C
 9504 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 204)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,174)  IOUT, JINC
      WRITE (2,174)  IOUT, JINC
      DD = DOUT(IOUT,JINC)
      CALL FRSPNS (A, B, C, DD, IOUT, JINC, N, TSFTR, DXM1, DXV1,
     * DXV2, DXV3, EX2, AR, AI, NMAX, NOMAX, DDCOF, DNCOF, FI, DELF, IF,
     * FREQ, AMP, PHASE, ISPACE, 1)
      DO 6019  I = 1,450
 6019 WHEN(I,15) = .TRUE.
      RETURN
C
C     PLOT OPEN LOOP FREQUENCY RESPONSE OF OUTPUT IOUT TO CONTROL
C     INPUT JINC
C
 9505 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 205)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8820)
      WRITE (6,8820)
      DO 621  I = 1,15
      TB(I) = TB1(I)
  621 TTITL(I) = T3(I)
      TTITL(5) = TNUM(IOUT)
      TTITL(10) = TNUM(JINC)
      IF (LINLOG .EQ. 1 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP, AMP1, PHASE, PHA1, TTITL, TB, IF, 1,
     * AMPSTR, PHASTR, SETAP, 4, 4, IP, NAME, IONPLT)
      IF (LINLOG .EQ. 2 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP, AMP1, PHASE, PHA1, TTITL, TB, IF, 1,
     * AMPSTR, PHASTR, SETAP, 3, 2, IP, NAME, IONPLT)
      RETURN
C
C     STORE OPEN LOOP FREQUENCY REPONSE OF OUTPUT IOUT TO CONTROL INPUT
C     JINC IN A DATASET USING UNIT 11
C
 9506 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 206)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8819)
      WRITE (6,8819)
      WRITE (11,230)  (FREQ(I), AMP(I), PHASE(I),  I = 1,IF)
      RETURN
C
C     OPEN LOOP FREQUENCY RESPONSE OF MEASUREMENT IMEAS TO DISTURBANCE
C     INPUT JIND
C
 9507 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 207)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,176)  IMEAS, JIND
      WRITE (2,176)  IMEAS, JIND
      DD = 0.0D0
      CALL FRSPNS (A, D, H, DD, IMEAS, JIND, N, TSFTR, DXM1, DXV1,
     * DXV2, DXV3, EX2, AR, AI, NMAX, NMMAX, DDCOF, DNCOF, FI, DELF, IF,
     * FREQ, AMP, PHASE, ISPACE, 1)
      DO 61  I = 1,IF
      AMP3(I) = AMP(I)
   61 PHA3(I) = PHASE(I)
      DO 6026  I = 1,450
 6026 WHEN(I,16) = .TRUE.
      RETURN
C
C     PLOT OPEN LOOP FREQUENCY RESPONSE OF MEASUREMENT IMEAS TO
C     DISTURBANCE INPUT JIND
C
 9508 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 208)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8822)
      WRITE (6,8822)
      DO 627  I = 1,15
      TB(I) = TB1(I)
  627 TTITL(I) = T8(I)
      TTITL(5) = TNUM(IMEAS)
      TTITL(10) = TNUM(JIND)
      IF (LINLOG .EQ. 1 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP, AMP1, PHASE, PHA1, TTITL, TB, IF, 1,
     * AMPSTR, PHASTR, SETAP, 4, 4, IP, NAME, IONPLT)
      IF (LINLOG .EQ. 2 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP, AMP1, PHASE, PHA1, TTITL, TB, IF, 1,
     * AMPSTR, PHASTR, SETAP, 3, 2, IP, NAME, IONPLT)
      RETURN
C
C     STORE OPEN LOOP FREQUENCY RESPONSE OF MEASUREMENT IMEAS TO
C     DISTURBANCE INPUT JIND IN A DATASET USING UNIT 12
C
 9509 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 209)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8823)
      WRITE (6,8823)
      WRITE (12,230)  (FREQ(I), AMP(I), PHASE(I),  I = 1,IF)
      RETURN
C
C     OPEN LOOP FREQUENCY RESPONSE OF OUTPUT IOUT TO DISTURBANCE
C     INPUT JIND
C
 9510 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 210)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,183)  IOUT, JIND
      WRITE (2,183)  IOUT, JIND
      DD = DOUT(IOUT,JIND)
      CALL FRSPNS (A, D, C, DD, IOUT, JIND, N, TSFTR, DXM1, DXV1,
     * DXV2, DXV3, EX2, AR, AI, NMAX, NOMAX, DDCOF, DNCOF, FI, DELF, IF,
     * FREQ, AMP, PHASE, ISPACE, 1)
      DO 60  I = 1,IF
      AMP1(I) = AMP(I)
   60 PHA1(I) = PHASE(I)
      DO 6020  I = 1,450
 6020 WHEN(I,17) = .TRUE.
      RETURN
C
C     PLOT OPEN LOOP FREQUENCY RESPONSE OF OUTPUT IOUT TO DISTURBANCE
C     INPUT JIND
C
 9511 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 211)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8817)
      WRITE (6,8817)
      DO 96  I = 1,15
      TB(I) = TB1(I)
   96 TTITL(I) = T1(I)
      TTITL(5) = TNUM(IOUT)
      TTITL(10) = TNUM(JIND)
      IF (LINLOG .EQ. 1 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP, AMP1, PHASE, PHA1, TTITL, TB, IF, 1,
     * AMPSTR, PHASTR, SETAP, 4, 4, IP, NAME, IONPLT)
      IF (LINLOG .EQ. 2 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP, AMP1, PHASE, PHA1, TTITL, TB, IF, 1,
     * AMPSTR, PHASTR, SETAP, 3, 2, IP, NAME, IONPLT)
      RETURN
C
C     STORE OPEN LOOP FREQUENCY RESPONSE OF OUTPUT IOUT TO DISTURBANCE
C     INPUT JIND IN A DATASET USING UNIT 13
C
 9512 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 212)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8825)
      WRITE (6,8825)
      WRITE (13,230)  (FREQ(I), AMP(I), PHASE(I),  I = 1,IF)
      RETURN
C
C     CLOSED LOOP FREQUENCY RESPONSE OF OUTPUT IOUT TO DISTURBANCE
C     INPUT JIND FOR STATE FEEDBACK
C
 9513 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 213)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,187)  IOUT, JIND
      WRITE (2,187)  IOUT, JIND
      DD = DOUT(IOUT,JIND)
      CALL FRSPNS (AMBKC, D, C, DD, IOUT, JIND, N, TSFTR, DXM1,
     * DXV1, DXV2, DXV3, EX2, AR, AI, NMAX, NOMAX, DDCOF, DNCOF, FI,
     * DELF, IF, FREQ, AMP, PHASE, ISPACE, 1)
      DO 94  I = 1,IF
      AMP2(I) = AMP(I)
   94 PHA2(I) = PHASE(I)
      DO 6021  I = 1,450
 6021 WHEN(I,18) = .TRUE.
      RETURN
C
C     IF NCURV = 2, PLOT CLOSED LOOP FREQUENCY RESPONSE OF OUTPUT
C     IOUT TO DISTURBANCE INPUT JIND FOR STATE FEEDBACK (PLUS THE
C     CORRESPONDING OPEN LOOP RESPONSE FROM 510)
C     IF NCURV = 1, PLOT ONLY THE CLOSED LOOP RESPONSE
C
 9514 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 214)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8824)
      WRITE (6,8824)
      DO 97  I = 1,15
      TB(I) = TB2(I)
   97 TTITL(I) = T9(I)
      TTITL(5) = TNUM(IOUT)
      TTITL(10) = TNUM(JIND)
      IF (LINLOG .EQ. 1 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP2, AMP1, PHA2, PHA1, TTITL, TB, IF, NCURV,
     * AMPSTR, PHASTR, SETAP, 4, 4, IP, NAME, IONPLT)
      IF (LINLOG .EQ. 2 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP2, AMP1, PHA2, PHA1, TTITL, TB, IF, NCURV,
     * AMPSTR, PHASTR, SETAP, 3, 2, IP, NAME, IONPLT)
      RETURN
C
C     CLOSED LOOP FREQUENCY RESPONSE OF CONTROL JINC TO DISTURBANCE
C     INPUT JIND FOR STATE FEEDBACK
C
 9515 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 215)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,170)  JINC, JIND
      WRITE (2,170)  JINC, JIND
      DO 1020  J = 1,N
      DO 1020  I = 1,NC
 1020 KC(I,J) = - KC(I,J)
      DD = 0.0D0
      CALL FRSPNS (AMBKC, D, KC, DD, JINC, JIND, N, TSFTR, DXM1,
     * DXV1, DXV2, DXV3, EX2, AR, AI, NMAX, NCMAX, DDCOF, DNCOF, FI,
     * DELF, IF, FREQ, AMP, PHASE, ISPACE, 1)
      DO 115  J = 1,N
      DO 115  I = 1,NC
  115 KC(I,J) = - KC(I,J)
      DO 6022  I = 1,450
 6022 WHEN(I,19) = .TRUE.
      RETURN
C
C     PLOT CLOSED LOOP FREQUENCY RESPONSE OF CONTROL JINC TO DISTURBANCE
C     INPUT JIND FOR STATE FEEDBACK
C
 9516 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 216)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8826)
      WRITE (6,8826)
      DO 114  I = 1,15
      TB(I) = TB2(I)
  114 TTITL(I) = T2(I)
      TTITL(5) = TNUM(JINC)
      TTITL(10) = TNUM(JIND)
      IF (LINLOG .EQ. 1 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP, AMP1, PHASE, PHA1, TTITL, TB, IF, 1,
     * AMPSTR, PHASTR, SETAP, 4, 4, IP, NAME, IONPLT)
      IF (LINLOG .EQ. 2 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP, AMP1, PHASE, PHA1, TTITL, TB, IF, 1,
     * AMPSTR, PHASTR, SETAP, 3, 2, IP, NAME, IONPLT)
      RETURN
C
C     CLOSED LOOP FREQUENCY RESPONSE OF MEASUREMENT IMEAS TO DISTURBANCE
C     INPUT JIND FOR CONTROL SYSTEM WITH A FILTER IN THE FEEDBACK LOOP
C
 9517 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 217)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,808)  IMEAS, JIND
      WRITE (2,808)  IMEAS, JIND
      DD = 0.0D0
      CALL FRSPNS (ATOT, DTOT, HTOT, DD, IMEAS, JIND, NTOT,
     * TSFTR, DXMT1, DXVT1, DXVT2, DXVT3, TT, AR, AI, NTOTMX, NMMAX,
     * DDCOFT, DNCOFT, FI, DELF, IF, FREQ, AMP, PHASE, ISPACE, 1)
      DO 91  I = 1,IF
      AMP2(I) = AMP(I)
   91 PHA2(I) = PHASE(I)
      DO 7026  I = 1,450
 7026 WHEN(I,20) = .TRUE.
      RETURN
C
C     IF NCURV = 2, PLOT CLOSED LOOP FREQUENCY RESPONSE OF
C     MEASUREMENT IMEAS TO DISTURBANCE INPUT JIND FOR CONTROL
C     SYSTEM WITH A FILTER IN THE FEEDBACK LOOP (PLUS THE
C     CORRESPONDING OPEN LOOP RESPONSE FROM 507)
C     IF NCURV = 1, PLOT ONLY THE CLOSED LOOP RESPONSE
C
 9518 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 218)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8829)
      WRITE (6,8829)
      DO 7025  I = 1,15
      TB(I) = TB2(I)
      TB(I) = TB2(I)
 7025 TTITL(I) = T5(I)
      TTITL(5) = TNUM(IMEAS)
      TTITL(10) = TNUM(JIND)
      IF (LINLOG .EQ. 1 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP2, AMP3, PHA2, PHA3, TTITL, TB, IF, NCURV,
     * AMPSTR, PHASTR, SETAP, 4, 4, IP, NAME, IONPLT)
      IF (LINLOG .EQ. 2 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP2, AMP3, PHA2, PHA3, TTITL, TB, IF, NCURV,
     * AMPSTR, PHASTR, SETAP, 3, 2, IP, NAME, IONPLT)
      RETURN
C
C     CLOSED LOOP FREQUENCY RESPONSE OF OUTPUT IOUT TO DISTURBANCE INPUT
C     JIND FOR CONTROL SYSTEM WITH A FILTER IN THE FEEDBACK LOOP
C
 9519 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 219)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,809)  IOUT, JIND
      WRITE (2,809)  IOUT, JIND
      DD = 0.0D0
      CALL FRSPNS (ATOT, DTOT, CTOT, DD, IOUT, JIND, NTOT,
     * TSFTR, DXMT1, DXVT1, DXVT2, DXVT3, TT, AR, AI, NTOTMX, NOMAX,
     * DDCOFT, DNCOFT, FI, DELF, IF, FREQ, AMP, PHASE, ISPACE, 1)
      DO 92  I = 1,IF
      AMP2(I) = AMP(I)
   92 PHA2(I) = PHASE(I)
      DO 6024  I = 1,450
 6024 WHEN(I,21) = .TRUE.
      RETURN
C
C     IF NCURV = 2, PLOT CLOSED LOOP FREQUENCY RESPONSE OF
C     OUTPUT IOUT TO DISTURBANCE INPUT JIND FOR CONTROL
C     SYSTEM WITH A FILTER IN THE FEEDBACK LOOP (PLUS THE
C     CORRESPONDING OPEN LOOP RESPONSE FROM 510)
C     IF NCURV = 1, PLOT ONLY THE CLOSED LOOP RESPONSE
C
 9520 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 220)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8830)
      WRITE (6,8830)
      DO 818  I = 1,15
      TB(I) = TB2(I)
  818 TTITL(I) = T6(I)
      TTITL(5) = TNUM(IOUT)
      TTITL(10) = TNUM(JIND)
      IF (LINLOG .EQ. 1 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP2, AMP1, PHA2, PHA1, TTITL, TB, IF, NCURV,
     * AMPSTR, PHASTR, SETAP, 4, 4, IP, NAME, IONPLT)
      IF (LINLOG .EQ. 2 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP2, AMP1, PHA2, PHA1, TTITL, TB, IF, NCURV,
     * AMPSTR, PHASTR, SETAP, 3, 2, IP, NAME, IONPLT)
      RETURN
C
C     CLOSED LOOP FREQUENCY RESPONSE OF CONTROL JINC TO DISTURBANCE
C     INPUT JIND FOR CONTROL SYSTEM WITH A FILTER IN THE FEEDBACK LOOP
C
 9521 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 221)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,810)  JINC, JIND
      WRITE (2,810)  JINC, JIND
      DD = 0.0D0
      CALL FRSPNS (ATOT, DTOT, KCTOT, DD, JINC, JIND, NTOT,
     * TSFTR, DXMT1, DXVT1, DXVT2, DXVT3, TT, AR, AI, NTOTMX, NCMAX,
     * DDCOFT, DNCOFT, FI, DELF, IF, FREQ, AMP, PHASE, ISPACE, 1)
      DO 7027  I = 1,450
 7027 WHEN(I,22) = .TRUE.
      RETURN
C
C     PLOT CLOSED LOOP FREQUENCY RESPONSE OF CONTROL JINC TO DISTURBANCE
C     INPUT JIND FOR CONTROL SYSTEM WITH A FILTER IN THE FEEDBACK LOOP
C
 9522 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 222)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8831)
      WRITE (6,8831)
      DO 7028  I = 1,15
      TB(I) = TB2(I)
 7028 TTITL(I) = T7(I)
      TTITL(5) = TNUM(JINC)
      TTITL(10) = TNUM(JIND)
      IF (LINLOG .EQ. 1 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP, AMP1, PHASE, PHA1, TTITL, TB, IF, 1,
     * AMPSTR, PHASTR, SETAP, 4, 4, IP, NAME, IONPLT)
      IF (LINLOG .EQ. 2 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP, AMP1, PHASE, PHA1, TTITL, TB, IF, 1,
     * AMPSTR, PHASTR, SETAP, 3, 2, IP, NAME, IONPLT)
      RETURN
C
C     FREQUENCY RESPONSE OF CONTROL JINC TO MEASUREMENT
C     IMEAS FOR OPTIMAL CONTROLLER
C
 9523 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 223)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,192)  JINC, IMEAS
      WRITE (2,192)  JINC, IMEAS
      DO 8173  J = 1,N
      DO 8173  I = 1,NC
 8173 KC(I,J) = - KC(I,J)
      DD = 0.0D0
      CALL FRSPNS (ABKCEH, KE, KC, DD, JINC, IMEAS, N, TSFTR, DXM1,
     * DXV1, DXV2, DXV3, EX2, AR, AI, NMAX, NCMAX, DDCOF, DNCOF, FI,
     * DELF, IF, FREQ, AMP, PHASE, ISPACE, 1)
      DO 8177  J = 1,N
      DO 8177  I = 1,NC
 8177 KC(I,J) = - KC(I,J)
      DO 6023  I = 1,450
 6023 WHEN(I,23) = .TRUE.
      RETURN
C
C     PLOT FREQUENCY RESPONSE OF CONTROL JINC TO MEASUREMENT
C     IMEAS FOR OPTIMAL CONTROLLER
C
 9524 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 224)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8828)
      WRITE (6,8828)
      DO 8180  I = 1,15
      TB(I) = TB3(I)
 8180 TTITL(I) = T4(I)
      TTITL(5) = TNUM(JINC)
      TTITL(10) = TNUM(IMEAS)
      IF (LINLOG .EQ. 1 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP, AMP1, PHASE, PHA1, TTITL, TB, IF, 1,
     * AMPSTR, PHASTR, SETAP, 4, 4, IP, NAME, IONPLT)
      IF (LINLOG .EQ. 2 .OR. LINLOG .EQ. 3)
     * CALL BODE (FREQ, AMP, AMP1, PHASE, PHA1, TTITL, TB, IF, 1,
     * AMPSTR, PHASTR, SETAP, 3, 2, IP, NAME, IONPLT)
      RETURN
C
C     STORE FREQUENCY RESPONSE OF CONTROL JINC TO
C     MEASUREMENT IMEAS FOR OPTIMAL CONTROLLER IN A DATASET USING
C     UNIT 14
C
 9525 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 225)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8827)
      WRITE (6,8827)
      WRITE (14,230)  (FREQ(I), AMP(I), PHASE(I),  I = 1,IF)
      RETURN
C
C
C             FORMATS
C
C
  170 FORMAT (1X, 'CLOSED LOOP FREQUENCY RESPONSE OF CONTROL ', I2, ' TO
     * DISTURBANCE INPUT ', I2 / 1X, 'FOR STATE FEEDBACK' / )
  174 FORMAT (1X, 'OPEN LOOP FREQUENCY RESPONSE OF OUTPUT ', I2, ' TO CO
     *NTROL INPUT ', I2 / )
  175 FORMAT (1X, 'OPEN LOOP FREQUENCY RESPONSE OF MEASUREMENT ', I2, '
     *TO CONTROL INPUT ', I2 / )
  176 FORMAT (1X, 'OPEN LOOP FREQUENCY RESPONSE OF MEASUREMENT ', I2, '
     *TO DISTURBANCE INPUT ', I2 / )
  183 FORMAT (1X, 'OPEN LOOP FREQUENCY RESPONSE OF OUTPUT ', I2, ' TO DI
     *STURBANCE INPUT ', I2 / )
  187 FORMAT (1X, 'CLOSED LOOP FREQUENCY RESPONSE OF OUTPUT ', I2, ' TO
     *DISTURBANCE INPUT ', I2 / 1X, 'FOR STATE FEEDBACK' / )
  192 FORMAT (1X, 'FREQUENCY RESPONSE OF CONTROL ', I2, ' TO MEASUREMENT
     * ', I2 / 1X, 'FOR OPTIMAL CONTROLLER' / )
  230 FORMAT (10G12.5)
  808 FORMAT (1X, 'CLOSED LOOP FREQUENCY RESPONSE OF MEASUREMENT ', I2,
     * ' TO DISTURBANCE INPUT ', I2 / 1X, 'FOR CONTROL SYSTEM WITH A FIL
     *TER IN THE FEEDBACK LOOP' / )
  809 FORMAT (1X, 'CLOSED LOOP FREQUENCY RESPONSE OF OUTPUT ', I2, ' TO
     *DISTURBANCE INPUT ', I2 / 1X, 'FOR CONTROL SYSTEM WITH A FILTER IN
     * THE FEEDBACK LOOP' / )
  810 FORMAT (1X, 'CLOSED LOOP FREQUENCY RESPONSE OF CONTROL ', I2, ' TO
     * DISTURBANCE INPUT ', I2 / 1X, 'FOR CONTROL SYSTEM WITH A FILTER I
     *N THE FEEDBACK LOOP' / )
 8817 FORMAT (1X, 'PLOT OPEN LOOP FREQ. RESPONSE OF OUTPUT TO DISTURBANC
     *E INPUT' / )
 8818 FORMAT (1X, 'STORE OPEN LOOP FREQ. RESPONSE OF MEASUREMENT TO CONT
     *ROL INPUT ON UNIT 10' / )
 8819 FORMAT (1X, 'STORE OPEN LOOP FREQ. RESPONSE OF OUTPUT TO CONTROL I
     *NPUT ON UNIT 11' / )
 8820 FORMAT (1X, 'PLOT OPEN LOOP FREQ. RESPONSE OF OUTPUT TO CONTROL IN
     *PUT' / )
 8821 FORMAT (1X, 'PLOT OPEN LOOP FREQ. RESPONSE OF MEASUREMENT TO CONTR
     *OL INPUT' / )
 8822 FORMAT (1X, 'PLOT OPEN LOOP FREQ. RESPONSE OF MEASUREMENT TO DISTU
     *RBANCE INPUT' / )
 8823 FORMAT (1X, 'STORE OPEN LOOP FREQ. RESPONSE OF MEASUREMENT TO DIST
     *URBANCE INPUT ON UNIT 12' / )
 8824 FORMAT (1X, 'PLOT CLOSED LOOP FREQ. RESPONSE OF OUTPUT TO DISTURBA
     *NCE INPUT' / 1X, 'FOR STATE FEEDBACK' / 1X, '(PLUS THE CORRESPONDI
     *NG OPEN LOOP RESPONSE, IF DESIRED)' / )
 8825 FORMAT (1X, 'STORE OPEN LOOP FREQ. RESPONSE OF OUTPUT TO DISTURBAN
     *CE INPUT ON UNIT 13' / )
 8826 FORMAT (1X, 'PLOT CLOSED LOOP FREQ. RESPONSE OF CONTROL TO DISTURB
     *ANCE INPUT' / 1X, 'FOR STATE FEEDBACK' / )
 8827 FORMAT (1X, 'STORE FREQ. RESPONSE OF CONTROL TO MEASUREMENT' / 1X,
     * 'FOR OPTIMAL CONTROLLER ON UNIT 14' / )
 8828 FORMAT (1X, 'PLOT FREQ. RESPONSE OF CONTROL TO MEASUREMENT' / 1X,
     *'FOR OPTIMAL CONTROLLER' / )
 8829 FORMAT (1X, 'PLOT CLOSED LOOP FREQ. RESPONSE OF MEASUREMENT TO DIS
     *TURBANCE INPUT' / 1X, 'FOR CONTROL SYSTEM WITH FILTER IN FEEDBACK
     *LOOP' / 1X, '(PLUS THE CORRESPONDING OPEN LOOP RESPONSE, IF DESIRE
     *D)' / )
 8830 FORMAT (1X, 'PLOT CLOSED LOOP FREQ. RESPONSE OF OUTPUT TO DISTURBA
     *NCE INPUT' / 1X, 'FOR CONTROL SYSTEM WITH FILTER IN FEEDBACK LOOP'
     * / 1X, '(PLUS THE CORRESPONDING OPEN LOOP RESPONSE, IF DESIRED)' /
     * )
 8831 FORMAT (1X, 'PLOT CLOSED LOOP FREQ. RESPONSE OF CONTROL TO DISTURB
     *ANCE INPUT' / 1X, 'FOR CONTROL SYSTEM WITH FILTER IN FEEDBACK LOOP
     *' / )
      END
      SUBROUTINE AES600 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
C
C     ******************************************************************
C
C     SUBROUTINE AES600 CONTAINS THOSE FUNCTIONS WHICH CALCULATE
C     TIME RESPONSES AND THE ASSOCIATED PLOTS.
C     AES600 CALLS SUBROUTINES DSCRT, ICRSP, MATPRT, PREREQ, AND STP.
C     AES600 IS CALLED BY MAIN PROGRAM AESOP.
C
C     INPUTS:
C
C              IFN     VECTOR OF FUNCTION NUMBERS TO BE DONE (1000)
C              IFUNC   FUNCTION NUMBER
C              MZ      WHICH FUNCTION IS TO BE DONE
C              IPRT    PRINT OPTION:  1, STANDARD PRINT;
C                                     2, EXTENDED PRINT
C              WHEN    LOGICAL MATRIX OF PREREQUISITES (450,50)
C
C     OUTPUTS:
C
C              IAND    DECISION VARIABLE:
C                      0, PREREQUISITES HAVE BEEN DONE;
C                      1, PREREQUISITES HAVE NOT BEEN DONE
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-S,U-Z)
      LOGICAL  WHEN
      REAL*8  TSFTR, TT, TS2, NN, KC, KE, KFF, KCTOT
      COMMON /ABETC/ A(50,50), B(50,5), C(50,50), D(50,15), H(5,50),
     * QC(50,50), NN(50,5), PCINV(5,5), QQ(50,50), RRINV(5,5),
     * DOUT(50,5), CSP(5,50)
      COMMON /COM1/ ADBLE(2500), EX1(50,50), EX2(50,50), EX3(50,50),
     * EX4(50), EXT(100,100), KC(5,50), AMBKC(50,50), ANR(50), ANI(50),
     * EIGR(50), EIGI(50), X(100,100), EIGCLR(50), EIGCLI(50), TS2(100),
     * AR(100), AI(100), XR(100,100), TT(100,100), AAA1(100,100),
     * CR(100), CI(100), S(50,50), SS(50,50), SSS(50,50), FREQ(500),
     * AMP(500), PHASE(500), AMP1(500), PHA1(500), AMP2(500), PHA2(500),
     * AMP3(500), PHA3(500), AMPSTR(1000), PHASTR(1000), SETAP(500),
     * ABKCEH(50,50), KE(50,5), PP(50,50), KFF(5,5), AMPSP(5), AMPSR(5),
     * AMPICX(50), EX13(50,5), EX23(5,50), EX33(5,5), EX5(50,5),
     * EX6(5,50), EX7(5,5), IBL(100), IA(100), IB(100), LEX(100),
     * MEX(100), IC(100), MSROLX(5,50), MSROLY(5,50), MSPY(5,50),
     * MSPYSP(5,5), MSPU(5,5), MICOLX(50,50), MICOLY(50,50),
     * MICCLX(50,50), MICCLY(50,50), MICCLU(50,5)
      COMMON /COM2/ EXX1(50,50), EXX3(50,50), EXX5(50,5), SSSX(50,50)
      COMMON /COM3/ ATOT(100,100), CTOT(50,100), DTOT(100,15),
     * KCTOT(5,100), HTOT(5,100), XOLD(100), XNEW(100)
      COMMON /DIMS/  N, NM, NC, ND, NO, NTOT
      COMMON /DIMS2/  NMAX, NMMAX, NCMAX, NDMAX, NOMAX, NTOTMX
      COMMON /PRTOP/ IUNIT
      COMMON /SPREC/ TYOUT(1000,50), TY13(1000,5), TIME(1000), IONPLT,
     * ITRMXX
      COMMON /REFCOM/ TSFTR, DT, FI, DELF, ZERMAX, IF, ISPACE, IOUT,
     * IMEAS, JINC, JIND, ITRMX, NCURV, LINLOG, IP, NAME(9)
      COMMON /TRTIT/ TTIT1(12), TTIT2(12), TTIT3(12), TTIT4(12),
     * TTIT5A(11), TTIT5B(11), TTIT5C(11), TUU(4), TXX(4), TYY(4),
     * TYSPD(4), TYSP(4)
      DIMENSION  IFN(1000), WHEN(450,50)
C
C
C
      IFUNC = IFUNC - 600
      GO TO (9601,9602,9603,9604), IFUNC
C
C     OBTAIN AND PLOT SELECTED OPEN LOOP STEP RESPONSES (DEPENDENT ON
C     MSROLY AND MSROLX).  THE INPUTS ARE THE CONTROL VARIABLES AND THE
C     RESPONSES ARE THE Y OUTPUTS AND THE X STATES.
C
 9601 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 251)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8845)
      WRITE (6,8845)
      CALL DSCRT (DT, A, N, NMAX, ITIMES, EX1, EX2, EX4)
      WRITE (6,8846)  DT
      CALL MATPRT (EX1, N, N, NMAX)
      WRITE (6,8847)  DT
      CALL MATPRT (EX2, N, N, NMAX)
      IF (IPRT .EQ. 1)  GO TO  70
      IUNIT = 2
      WRITE (2,8846)  DT
      CALL MATPRT (EX1, N, N, NMAX)
      WRITE (2,8847)  DT
      CALL MATPRT (EX2, N, N, NMAX)
      IUNIT = 6
      DO 1  I = 1,4
    1 TTIT5B(I+7) = TUU(I)
      DO 5  J = 1,NO
      DO 5  I = 1,NC
      IF (MSROLY(I,J) .EQ. 1)  GO TO 70
    5 CONTINUE
      GO TO 75
   70 DO 355  I = 1,NO
      DO 352  J = 1,N
  352 SSSX(I,J) = C(I,J)
      DO 355  K = 1,NC
  355 EXX5(I,K) = DOUT(I,K)
      WRITE (6,250)
      WRITE (6,8848)
      WRITE (6,8849)
      CALL STP (EX1, EX2, B, SSSX, EXX5, MSROLY, AMPSR, DT, TIME, TYOUT,
     * XNEW, XOLD, ANR, TTIT2, TTIT5B, TYY, LEX, N, NC, NO, ITRMX, NMAX,
     * NCMAX, NOMAX, ITRMXX, IP, NAME, IONPLT)
   75 DO 10  J = 1,N
      DO 10  I = 1,NC
      IF (MSROLX(I,J) .EQ. 1)  GO TO 80
   10 CONTINUE
      RETURN
   80 DO 353  I = 1,N
      DO 351  J = 1,N
      SSS(I,J) = 0.0D0
      IF (I .EQ. J)  SSS(I,J) = 1.0D0
  351 CONTINUE
      DO 353  K = 1,NC
  353 EX5(I,K) = 0.0D0
      WRITE (6,250)
      WRITE (6,8848)
      WRITE (6,8850)
      CALL STP (EX1, EX2, B, SSS, EX5, MSROLX, AMPSR, DT, TIME, TYOUT,
     * XNEW, XOLD, ANR, TTIT2, TTIT5B, TXX, LEX, N, NC, N, ITRMX, NMAX,
     * NCMAX, NMAX, ITRMXX, IP, NAME, IONPLT)
      RETURN
C
C     OBTAIN AND PLOT SELECTED INITIAL CONDITION RESPONSES (DEPENDENT ON
C     MICOLY AND MICOLX) FOR THE OPEN LOOP SYSTEM
C
 9602 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 252)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8150)
      WRITE (6,8150)
      CALL DSCRT (DT, A, N, NMAX, ITIMES, EX1, EX2, EX4)
      WRITE (6,8846)  DT
      CALL MATPRT (EX1, N, N, NMAX)
      WRITE (6,8847)  DT
      CALL MATPRT (EX2, N, N, NMAX)
      IF (IPRT .EQ. 1)  GO TO 72
      IUNIT  = 2
      WRITE (2,8846)  DT
      CALL MATPRT (EX1, N, N, NMAX)
      WRITE (2,8847)  DT
      CALL MATPRT (EX2, N, N, NMAX)
      IUNIT = 6
      DO 2  I = 1,4
    2 TTIT5C(I+7) = TXX(I)
      DO 15  J = 1,NO
      DO 15  I = 1,N
      IF (MICOLY(I,J) .EQ. 1)  GO TO 72
   15 CONTINUE
      GO TO 85
   72 DO 73  J = 1,N
      DO 73  I = 1,NO
   73 SSSX(I,J) = C(I,J)
      WRITE (6,250)
      WRITE (6,8153)
      WRITE (6,8154)
      CALL ICRSP (EX1, SSSX, MICOLY, AMPICX, DT, TIME, TYOUT, XNEW,
     * XOLD, TTIT4, TTIT5C, TYY, LEX, N, NO, ITRMX, NMAX, NOMAX, ITRMXX,
     * IP, NAME, IONPLT)
   85 DO 20  J = 1,N
      DO 20  I = 1,N
      IF (MICOLX(I,J) .EQ. 1)  GO TO 90
   20 CONTINUE
      RETURN
   90 DO 74  J = 1,N
      DO 74  I = 1,N
      SSS(I,J) = 0.0D0
      IF (I .EQ. J)  SSS(I,J) = 1.0D0
   74 CONTINUE
      WRITE (6,250)
      WRITE (6,8153)
      WRITE (6,8155)
      CALL ICRSP (EX1, SSS, MICOLX, AMPICX, DT, TIME, TYOUT, XNEW, XOLD,
     * TTIT4, TTIT5C, TXX, LEX, N, N, ITRMX, NMAX, NMAX, ITRMXX, IP,
     * NAME, IONPLT)
      RETURN
C
C     OBTAIN AND PLOT SELECTED INITIAL CONDITION RESPONSES (DEPENDENT
C     ON MICCLY, MICCLX, AND MICCLU) FOR THE CLOSED LOOP LINEAR
C     REGULATOR.  THE INPUTS ARE STATE INITIAL CONDITIONS AND THE
C     RESPONSES ARE THE Y OUTPUTS, THE X STATES AND THE U CONTROL
C     VARIABLES.  THE  I.C.'S ARE STORED IN AMPICX.
C
 9603 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 253)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8851)
      WRITE (6,8851)
      CALL DSCRT (DT, AMBKC, N, NMAX, ITIMES, EX1, EX2, EX4)
      WRITE (6,8190)  DT
      CALL MATPRT (EX1, N, N, NMAX)
      WRITE (6,8191)  DT
      CALL MATPRT (EX2, N, N, NMAX)
      IF (IPRT .EQ. 1)  GO TO  71
      IUNIT = 2
      WRITE (2,8190)  DT
      CALL MATPRT (EX1, N, N, NMAX)
      WRITE (2,8191)  DT
      CALL MATPRT (EX2, N, N, NMAX)
      IUNIT = 6
      DO 3  I = 1,4
    3 TTIT5C(I+7) = TXX(I)
      DO 25  J = 1,NO
      DO 25  I = 1,N
      IF (MICCLY(I,J) .EQ. 1)  GO TO 71
   25 CONTINUE
      GO TO 95
   71 DO 360  J = 1,N
      DO 360  I = 1,NO
      SSSX(I,J) = C(I,J)
      DO 360  K = 1,NC
  360 SSSX(I,J) = SSSX(I,J) - DOUT(I,K) * KC(K,J)
      WRITE (6,250)
      WRITE (6,8855)
      WRITE (6,8856)
      CALL ICRSP (EX1, SSSX, MICCLY, AMPICX, DT, TIME, TYOUT, XNEW,
     * XOLD, TTIT3, TTIT5C, TYY, LEX, N, NO, ITRMX, NMAX, NOMAX, ITRMXX,
     * IP, NAME, IONPLT)
   95 DO 30  J = 1,N
      DO 30  I = 1,N
      IF (MICCLX(I,J) .EQ. 1)  GO TO 100
   30 CONTINUE
      GO TO 105
  100 DO 362  J = 1,N
      DO 362  I = 1,N
      SSS(I,J) = 0.0D0
      IF (I .EQ. J)  SSS(I,J) = 1.0D0
  362 CONTINUE
      WRITE (6,250)
      WRITE (6,8855)
      WRITE (6,8857)
      CALL ICRSP (EX1, SSS, MICCLX, AMPICX, DT, TIME, TYOUT, XNEW, XOLD,
     * TTIT3, TTIT5C, TXX, LEX, N, N, ITRMX, NMAX, NMAX, ITRMXX, IP,
     * NAME, IONPLT)
  105 DO 35  J = 1,NC
      DO 35  I = 1,N
      IF (MICCLU(I,J) .EQ. 1)  GO TO 110
   35 CONTINUE
      RETURN
  110 DO 365  J = 1,N
      DO 365  I = 1,NC
  365 EX13(I,J) = - KC(I,J)
      WRITE (6,250)
      WRITE (6,8855)
      WRITE (6,8858)
      CALL ICRSP (EX1, EX13, MICCLU, AMPICX, DT, TIME, TYOUT, XNEW,
     * XOLD, TTIT3, TTIT5C, TUU, LEX, N, NC, ITRMX, NMAX, NCMAX, ITRMXX,
     * IP, NAME, IONPLT)
      RETURN
C
C     OBTAIN AND PLOT SELECTED STEP RESPONSES (DEPENDENT ON MSPY,
C     MSPYSP, AND MSPU) FOR THE NON-ZERO SET POINT LINEAR REGULATOR.
C     THE INPUTS ARE STEP CHANGES IN SET POINT COMMANDS AND THE
C     RESPONSES ARE THE Y OUTPUTS, THE YSP (SET-POINT) OUTPUTS, AND THE
C     U CONTROL VARIABLES.
C
 9604 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 254)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8842)
      WRITE (6,8842)
      DO 310  J = 1,NC
      DO 310  I = 1,N
      EX13(I,J) = 0.0D0
      DO 310  K = 1,NC
  310 EX13(I,J) = EX13(I,J) + B(I,K) * KFF(K,J)
      CALL DSCRT (DT, AMBKC, N, NMAX, ITIMES, EX1, EX2, EX4)
      WRITE (6,8190)  DT
      CALL MATPRT (EX1, N, N, NMAX)
      WRITE (6,8191)  DT
      CALL MATPRT (EX2, N, N, NMAX)
      IF (IPRT .EQ. 1)  GO TO  69
      IUNIT = 2
      WRITE (2,8190)  DT
      CALL MATPRT (EX1, N, N, NMAX)
      WRITE (2,8191)  DT
      CALL MATPRT (EX2, N, N, NMAX)
      IUNIT = 6
      DO 4  I = 1,4
    4 TTIT5A(I+7) = TYSPD(I)
      DO 40  J = 1,NO
      DO 40  I = 1,NC
      IF (MSPY(I,J) .EQ. 1)  GO TO 69
   40 CONTINUE
      GO TO 115
   69 DO 320  J = 1,N
      DO 320  I = 1,NO
      SSSX(I,J) = C(I,J)
      DO 320  K = 1,NC
  320 SSSX(I,J) = SSSX(I,J) - DOUT(I,K) * KC(K,J)
      DO 321  J = 1,NC
      DO 321  I = 1,NO
      EXX5(I,J) = 0.0D0
      DO 321  K = 1,NC
  321 EXX5(I,J) = EXX5(I,J) + DOUT(I,K) * KFF(K,J)
      WRITE (6,250)
      WRITE (6,8206)
      WRITE (6,8199)
      CALL STP (EX1, EX2, EX13, SSSX, EXX5, MSPY, AMPSP, DT, TIME,
     * TYOUT, XNEW, XOLD, ANR, TTIT1, TTIT5A, TYY, LEX, N, NC, NO,
     * ITRMX, NMAX, NCMAX, NOMAX, ITRMXX, IP, NAME, IONPLT)
  115 DO 45  J = 1,NC
      DO 45  I = 1,NC
      IF (MSPYSP(I,J) .EQ. 1)  GO TO 120
   45 CONTINUE
      GO TO 125
  120 DO 322  J = 1,N
      DO 322  I = 1,NC
  322 EX23(I,J) = CSP(I,J)
      DO 323  J = 1,NC
      DO 323  I = 1,NC
  323 EX33(I,J) = 0.0D0
      WRITE (6,250)
      WRITE (6,8206)
      WRITE (6,8202)
      CALL STP (EX1, EX2, EX13, EX23, EX33, MSPYSP, AMPSP, DT, TIME,
     * TY13, XNEW, XOLD, ANR, TTIT1, TTIT5A, TYSP, LEX, N, NC, NC,
     * ITRMX, NMAX, NCMAX, NCMAX, ITRMXX, IP, NAME, IONPLT)
  125 DO 50  J = 1,NC
      DO 50  I = 1,NC
      IF (MSPU(I,J) .EQ. 1)  GO TO 130
   50 CONTINUE
      RETURN
  130 DO 324  J = 1,N
      DO 324  I = 1,NC
  324 EX23(I,J) = - KC(I,J)
      DO 325  J = 1,NC
      DO 325  I = 1,NC
  325 EX33(I,J) = KFF(I,J)
      WRITE (6,250)
      WRITE (6,8206)
      WRITE (6,8205)
      CALL STP (EX1, EX2, EX13, EX23, EX33, MSPU, AMPSP, DT, TIME,
     * TY13, XNEW, XOLD, ANR, TTIT1, TTIT5A, TUU, LEX, N, NC, NC,
     * ITRMX, NMAX, NCMAX, NCMAX, ITRMXX, IP, NAME, IONPLT)
      RETURN
C
C
C             FORMATS
C
C
  250 FORMAT (1H0)
 8150 FORMAT (1X, 'OBTAIN AND PLOT SELECTED INITIAL CONDITION RESPONSES
     *FOR THE OPEN LOOP SYSTEM' / )
 8153 FORMAT (1X, 'INITIAL CONDITION RESPONSES FOR THE OPEN LOOP SYSTEM'
     * )
 8154 FORMAT (1X, 'RESPONSE VARIABLES:  OUTPUT VECTOR, Y', / 1X, 'INPUTS
     *:  INITIAL CONDITIONS')
 8155 FORMAT (1X, 'RESPONSE VARIABLES:  STATE VECTOR, X', / 1X, 'INPUTS:
     *  INITIAL CONDITIONS')
 8190 FORMAT (1X, 'STATE TRANSITION MATRIX OF LINEAR REGULATOR FOR TIME
     *STEP ', G10.4)
 8191 FORMAT (1X, 'FORCED RESPONSE MATRIX OF LINEAR REGULATOR FOR TIME S
     *TEP ', G10.4)
 8199 FORMAT (1X, 'RESPONSE VARIABLES:  OUTPUT VECTOR, Y', / 1X, 'INPUT
     *VARIABLES:  SET POINT COMMAND VECTOR, YSPD')
 8202 FORMAT (1X, 'RESPONSE VARIABLES:  SET POINT OUTPUT VECTOR, YSP', /
     * 1X, 'INPUT VARIABLES:  SET POINT COMMAND VECTOR, YSPD')
 8205 FORMAT (1X, 'RESPONSE VARIABLES:  CONTROL VECTOR, U', / 1X, 'INPUT
     * VARIABLES:  SET POINT COMMAND VECTOR, YSPD')
 8206 FORMAT (1X, 'STEP RESPONSES FOR NON-ZERO SET-POINT REGULATOR')
 8842 FORMAT (1X, 'OBTAIN AND PLOT SELECTED STEP RESPONSES' / 1X, 'FOR T
     *HE NON-ZERO SET POINT LINEAR REGULATOR' / )
 8845 FORMAT (1X, 'OBTAIN AND PLOT SELECTED OPEN LOOP STEP RESPONSES' /)
 8846 FORMAT (1X, 'STATE TRANSITION MATRIX FOR OPEN LOOP SYSTEM FOR TIME
     * STEP =', G10.4)
 8847 FORMAT (1X, 'FORCED RESPONSE MATRIX OF OPEN LOOP SYSTEM FOR TIME S
     *TEP =', G10.4)
 8848 FORMAT (1X, 'OPEN LOOP STEP RESPONSES' / )
 8849 FORMAT (1X, 'RESPONSE VARIABLES:  OUTPUT VECTOR, Y', / 1X, 'INPUT
     *VARIABLES:  CONTROL VECTOR, U')
 8850 FORMAT (1X, 'RESPONSE VARIABLES:  STATE VECTOR, X', / 1X, 'INPUT V
     *ARIABLES;  CONTROL, U')
 8851 FORMAT (1X, 'OBTAIN AND PLOT SELECTED INITIAL CONDITION RESPONSES'
     * / 1X, 'FOR THE CLOSED LOOP LINEAR REGULATOR' / )
 8855 FORMAT (1X, 'INITIAL CONDITION RESPONSES FOR THE CLOSED LOOP LINEA
     *R REGULATOR')
 8856 FORMAT (1X, 'RESPONSE VARIABLES:  OUTPUT VECTOR, Y', / 1X, 'INPUTS
     *:  INITIAL CONDITIONS')
 8857 FORMAT (1X, 'RESPONSE VARIABLES:  STATE VECTOR, X', / 1X, 'INPUTS:
     *  INITIAL CONDITIONS')
 8858 FORMAT (1X, 'RESPONSE VARIABLES:  CONTROL VECTOR, U', / 1X, 'INPUT
     *S:  INITIAL CONDITIONS')
      END
      SUBROUTINE AES700 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
C
C     ******************************************************************
C
C     SUBROUTINE AES700 CONTAINS THOSE FUNCTIONS WHICH CALCULATE
C     ZEROES AND GAINS.
C     AES700 CALLS SUBROUTINES GAIN, MATPRT, PREREQ, AND ZEROES.
C     AES700 IS CALLED BY MAIN PROGRAM AESOP.
C
C     INPUTS:
C
C              IFN     VECTOR OF FUNCTION NUMBERS TO BE DONE (1000)
C              IFUNC   FUNCTION NUMBER
C              MZ      WHICH FUNCTION IS TO BE DONE
C              IPRT    PRINT OPTION:  1, STANDARD PRINT;
C                                     2, EXTENDED PRINT
C              WHEN    LOGICAL MATRIX OF PREREQUISITES (450,50)
C
C     OUTPUTS:
C
C              IAND    DECISION VARIABLE:
C                      0, PREREQUISITES HAVE BEEN DONE;
C                      1, PREREQUISITES HAVE NOT BEEN DONE
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-S,U-Z)
      LOGICAL  WHEN
      REAL*8  TSFTR, TT, TS2, ICONST, NN, KC, KE, KFF, KCTOT
      COMMON /ABETC/ A(50,50), B(50,5), C(50,50), D(50,15), H(5,50),
     * QC(50,50), NN(50,5), PCINV(5,5), QQ(50,50), RRINV(5,5),
     * DOUT(50,5), CSP(5,50)
      COMMON /COM1/ ADBLE(2500), EX1(50,50), EX2(50,50), EX3(50,50),
     * EX4(50), EXT(100,100), KC(5,50), AMBKC(50,50), ANR(50), ANI(50),
     * EIGR(50), EIGI(50), X(100,100), EIGCLR(50), EIGCLI(50), TS2(100),
     * AR(100), AI(100), XR(100,100), TT(100,100), AAA1(100,100),
     * CR(100), CI(100), S(50,50), SS(50,50), SSS(50,50), FREQ(500),
     * AMP(500), PHASE(500), AMP1(500), PHA1(500), AMP2(500), PHA2(500),
     * AMP3(500), PHA3(500), AMPSTR(1000), PHASTR(1000), SETAP(500),
     * ABKCEH(50,50), KE(50,5), PP(50,50), KFF(5,5), AMPSP(5), AMPSR(5),
     * AMPICX(50), EX13(50,5), EX23(5,50), EX33(5,5), EX5(50,5),
     * EX6(5,50), EX7(5,5), IBL(100), IA(100), IB(100), LEX(100),
     * MEX(100), IC(100), MSROLX(5,50), MSROLY(5,50), MSPY(5,50),
     * MSPYSP(5,5), MSPU(5,5), MICOLX(50,50), MICOLY(50,50),
     * MICCLX(50,50), MICCLY(50,50), MICCLU(50,5)
      COMMON /DIMS/  N, NM, NC, ND, NO, NTOT
      COMMON /DIMS2/  NMAX, NMMAX, NCMAX, NDMAX, NOMAX, NTOTMX
      COMMON /PRTOP/ IUNIT
      COMMON /REFCOM/ TSFTR, DT, FI, DELF, ZERMAX, IF, ISPACE, IOUT,
     * IMEAS, JINC, JIND, ITRMX, NCURV, LINLOG, IP, NAME(9)
      DIMENSION  IFN(1000), WHEN(450,50)
C
C
C
      IFUNC = IFUNC - 700
      GO TO (9701,9702,9703,9704,9705), IFUNC
C
C     GAIN AND ZEROES FOR OPEN LOOP TRANSFER FUNCTION
C     RELATING MEASUREMENT IMEAS TO CONTROL INPUT JINC
C
 9701 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 301)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,173)  IMEAS, JINC
      WRITE (2,173)  IMEAS, JINC
      ICONST = 1.D0
      DD = 0.0D0
      CALL ZEROES (A, B, H, DD, ICONST, ANR, ANI, N, IMEAS, JINC,
     * NZ, EX1, EX2, EX4, LEX, MEX, ZERMAX, IA, IB, IBL, IC, S, SSS,
     * NMAX, NMMAX)
      CALL GAIN (A, B, H, DD, IMEAS, JINC, N, NZ, GAYN, EX1, EX4, NMAX,
     * NMMAX)
      WRITE (2,864)  GAYN
      WRITE (6,864)  GAYN
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,861)  NZ
      WRITE (2,862)
      CALL MATPRT (ANR, NZ, 1, NMAX)
      WRITE (2,863)
      CALL MATPRT (ANI, NZ, 1, NMAX)
      IUNIT = 6
      RETURN
C
C     GAIN AND ZEROES OF OPEN LOOP TRANSFER FUNCTION
C     RELATING OUTPUT IOUT TO CONTROL INPUT JINC
C
 9702 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 302)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,184)  IOUT, JINC
      WRITE (6,184)  IOUT, JINC
      ICONST = 1.D0
      DD = DOUT(IOUT,JINC)
      CALL ZEROES (A, B, C, DD, ICONST, ANR, ANI, N, IOUT, JINC,
     * NZ, EX1, EX2, EX4, LEX, MEX, ZERMAX, IA, IB, IBL, IC, S, SSS,
     * NMAX, NOMAX)
      CALL GAIN (A, B, C, DD, IOUT, JINC, N, NZ, GAYN, EX1, EX4, NMAX,
     * NOMAX)
      WRITE (2,864)  GAYN
      WRITE (6,864)  GAYN
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,861)  NZ
      WRITE (2,862)
      CALL MATPRT (ANR, NZ, 1, NMAX)
      WRITE (2,863)
      CALL MATPRT (ANI, NZ, 1, NMAX)
      IUNIT = 6
      RETURN
C
C     GAIN AND ZEROES OF OPEN LOOP TRANSFER FUNCTION
C     RELATING MEASUREMENT IMEAS TO DISTURBANCE INPUT JIND
C
 9703 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 303)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,171)  IMEAS, JIND
      WRITE (6,171)  IMEAS, JIND
      ICONST = 1.D0
      DD = 0.0D0
      CALL ZEROES (A, D, H, DD, ICONST, ANR, ANI, N, IMEAS, JIND,
     * NZ, EX1, EX2, EX4, LEX, MEX, ZERMAX, IA, IB, IBL, IC, S, SSS,
     * NMAX, NMMAX)
      CALL GAIN (A, D, H, DD, IMEAS, JIND, N, NZ, GAYN, EX1, EX4, NMAX,
     * NMMAX)
      WRITE (2,864)  GAYN
      WRITE (6,864)  GAYN
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,861)  NZ
      WRITE (2,862)
      CALL MATPRT (ANR, NZ, 1, NMAX)
      WRITE (2,863)
      CALL MATPRT (ANI, NZ, 1, NMAX)
      IUNIT = 6
      RETURN
C
C     GAIN AND ZEROES FOR OPEN LOOP TRANSFER FUNCTION
C     RELATING OUTPUT IOUT TO DISTURBANCE INPUT JIND
C
 9704 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 304)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,178)  IOUT, JIND
      WRITE (2,178)  IOUT, JIND
      ICONST = 1.D0
      DD = 0.0D0
      CALL ZEROES (A, D, C, DD, ICONST, ANR, ANI, N, IOUT, JIND,
     * NZ, EX1, EX2, EX4, LEX, MEX, ZERMAX, IA, IB, IBL, IC, S, SSS,
     * NMAX, NOMAX)
      CALL GAIN (A, D, C, DD, IOUT, JIND, N, NZ, GAYN, EX1, EX4, NMAX,
     * NOMAX)
      WRITE (2,864)  GAYN
      WRITE (6,864)  GAYN
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,861)  NZ
      WRITE (2,862)
      CALL MATPRT (ANR, NZ, 1, NMAX)
      WRITE (2,863)
      CALL MATPRT (ANI, NZ, 1, NMAX)
      IUNIT = 6
      RETURN
C
C     GAIN AND ZEROES OF OPTIMAL CONTROLLER TRANSFER
C     FUNCTION RELATING CONTROL JINC TO MEASUREMENT IMEAS
C
 9705 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 305)
      IF (IAND .EQ. 1)  RETURN
      ICONST = 1.D0
      WRITE (2,191)  JINC, IMEAS
      WRITE (6,191)  JINC, IMEAS
      DO 8171  J = 1,N
      DO 8171  I = 1,NC
 8171 KC(I,J) = - KC(I,J)
      DD = 0.0D0
      CALL ZEROES (ABKCEH, KE, KC, DD, ICONST, ANR, ANI, N, JINC,
     * IMEAS, NZ, EX1, EX2, EX4, LEX, MEX, ZERMAX, IA, IB, IBL, IC,
     * S, SSS, NMAX, NCMAX)
      DO 8174  J = 1,N
      DO 8174  I = 1,NC
 8174 KC(I,J) = - KC(I,J)
      CALL GAIN (ABKCEH, KE, KC, DD, JINC, IMEAS, N, NZ, GAYN, EX1, EX4,
     * NMAX, NCMAX)
      WRITE (2,864)  GAYN
      WRITE (6,864)  GAYN
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,861)  NZ
      WRITE (2,862)
      CALL MATPRT (ANR, NZ, 1, NMAX)
      WRITE (2,863)
      CALL MATPRT (ANI, NZ, 1, NMAX)
      IUNIT = 6
      RETURN
C
C
C             FORMATS
C
C
  171 FORMAT (1X, 'GAIN AND ZEROES OF OPEN LOOP TRANSFER FUNCTION' / 1X,
     * 'RELATING MEASUREMENT ', I2, ' TO DISTURBANCE INPUT ', I2 / )
  173 FORMAT (1X, 'GAIN AND ZEROES OF OPEN LOOP TRANSFER FUNCTION' / 1X,
     * 'RELATING MEASUREMENT ', I2, ' TO CONTROL INPUT ', I2 / )
  178 FORMAT (1X, 'GAIN AND ZEROES OF OPEN LOOP TRANSFER FUNCTION' / 1X,
     * 'RELATING OUTPUT ', I2, ' TO DISTURBANCE INPUT ', I2 / )
  184 FORMAT (1X, 'GAIN AND ZEROES OF OPEN LOOP TRANSFER FUNCTION' / 1X,
     * 'RELATING OUTPUT ', I2, ' TO CONTROL INPUT ', I2 / )
  191 FORMAT (1X, 'GAIN AND ZEROES OF OPTIMAL CONTROLLER TRANSFER FUNCTI
     *ON' / 1X, 'RELATING CONTROL ', I2, ' TO MEASUREMENT ', I2 / )
  861 FORMAT (1X, 'NUMBER OF ZEROES = ', I2)
  862 FORMAT (1X, 'REAL PARTS OF NUMERATOR ZEROES' )
  863 FORMAT (1X, 'IMAGINARY PARTS OF NUMERATOR ZEROES' )
  864 FORMAT (1X, 'GAIN = ', G14.6)
      END
      SUBROUTINE AES800 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
C
C     ******************************************************************
C
C     SUBROUTINE AES800 CONTAINS THOSE FUNCTIONS WHICH CALCULATE
C     EIGENVALUES AND EIGENVECTORS OF CONTROLS OR FILTERS, AND THE
C     FEED FORWARD, RICCATI, AND COVARIANCE EQUATIONS.
C     AES800 CALLS SUBROUTINES CONTRL, COVAR, EGVCTR, EIGEN, ESTMAT,
C     LYPCK, MATPRT, MODSHP, MXINV, PREREQ, AND RICCHK
C     AES800 IS CALLED BY MAIN PROGRAM AESOP.
C
C     INPUTS:
C
C              IFN     VECTOR OF FUNCTION NUMBERS TO BE DONE (1000)
C              IFUNC   FUNCTION NUMBER
C              MZ      WHICH FUNCTION IS TO BE DONE
C              IPRT    PRINT OPTION:  1, STANDARD PRINT;
C                                     2, EXTENDED PRINT
C              WHEN    LOGICAL MATRIX OF PREREQUISITES (450,50)
C
C     OUTPUTS:
C
C              IAND    DECISION VARIABLE:
C                      0, PREREQUISITES HAVE BEEN DONE;
C                      1, PREREQUISITES HAVE NOT BEEN DONE
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-S,U-Z)
      LOGICAL  WHEN
      REAL*8  TSFTR, TT, TS2, NN, KC, KE, KFF, KCTOT
      COMMON /ABETC/ A(50,50), B(50,5), C(50,50), D(50,15), H(5,50),
     * QC(50,50), NN(50,5), PCINV(5,5), QQ(50,50), RRINV(5,5),
     * DOUT(50,5), CSP(5,50)
      COMMON /COM1/ ADBLE(2500), EX1(50,50), EX2(50,50), EX3(50,50),
     * EX4(50), EXT(100,100), KC(5,50), AMBKC(50,50), ANR(50), ANI(50),
     * EIGR(50), EIGI(50), X(100,100), EIGCLR(50), EIGCLI(50), TS2(100),
     * AR(100), AI(100), XR(100,100), TT(100,100), AAA1(100,100),
     * CR(100), CI(100), S(50,50), SS(50,50), SSS(50,50), FREQ(500),
     * AMP(500), PHASE(500), AMP1(500), PHA1(500), AMP2(500), PHA2(500),
     * AMP3(500), PHA3(500), AMPSTR(1000), PHASTR(1000), SETAP(500),
     * ABKCEH(50,50), KE(50,5), PP(50,50), KFF(5,5), AMPSP(5), AMPSR(5),
     * AMPICX(50), EX13(50,5), EX23(5,50), EX33(5,5), EX5(50,5),
     * EX6(5,50), EX7(5,5), IBL(100), IA(100), IB(100), LEX(100),
     * MEX(100), IC(100), MSROLX(5,50), MSROLY(5,50), MSPY(5,50),
     * MSPYSP(5,5), MSPU(5,5), MICOLX(50,50), MICOLY(50,50),
     * MICCLX(50,50), MICCLY(50,50), MICCLU(50,5)
      COMMON /COM3/ ATOT(100,100), CTOT(50,100), DTOT(100,15),
     * KCTOT(5,100), HTOT(5,100), XOLD(100), XNEW(100)
      COMMON /COM4/ ADBLET(5000), EXTOT1(100,100), SSSTOT(100,100),
     * STOT(100,100), AAA2(100,100), EXTOT4(100), EIGRT(100),
     * EIGIT(100)
      COMMON /COM6A/ XX(50,50), YY(50,50), ZZ(5,5), UU(5,5)
      COMMON /DIMS/  N, NM, NC, ND, NO, NTOT
      COMMON /DIMS2/  NMAX, NMMAX, NCMAX, NDMAX, NOMAX, NTOTMX
      COMMON /PRTOP/ IUNIT
      DIMENSION  IFN(1000), WHEN(450,50)
C
C
C
      IFUNC = IFUNC - 800
      GO TO (9801,9802,9803,9804,9805,9806,9807,9808,9809,9810,9811,
     * 9812,9813,9814,9815,9816,9817,9818,9819,9820), IFUNC
C
C     DESIGN A LINEAR QUADRATIC REGULATOR
C
 9801 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 351)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8832)
      WRITE (6,8832)
      CALL CONTRL (A, B, QC, NN, PCINV, KC, SS, CR, CI, X, TS2, XR, TT,
     * AAA1, EXT, AR, AI, LEX, MEX, ADBLE, N, NC, NTOT, 0, 0, NMAX,
     * NCMAX, NTOTMX)
      DO 6028  I = 1,450
      WHEN(I,3) = .TRUE.
      WHEN(I,5) = .TRUE.
      WHEN(I,10) = .TRUE.
 6028 WHEN(I,24) = .TRUE.
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,868)
      CALL MATPRT (SS, N, N, NMAX)
      WRITE (2,8227)
      CALL MATPRT (KC, NC, N, NCMAX)
      IUNIT = 6
      RETURN
C
C     STORE OPTIMAL CONTROL GAIN MATRIX KC IN A DATASET USING UNIT 08
C
 9802 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 352)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8835)
      WRITE (6,8835)
      WRITE (8)  ((KC(I,J),  I = 1,NC),  J = 1,N)
      RETURN
C
C     OBTAIN EIGENVALUES OF SYSTEM WITH STATE FEEDBACK
C
 9803 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 353)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,82)
      WRITE (2,82)
      CALL EIGEN (AMBKC, EIGCLR, EIGCLI, EX1, SSS, S, IA, IB, LEX, MEX,
     * IBL, IC, EX4, N, NMAX)
      DO 6027  I = 1,450
 6027 WHEN(I,25) = .TRUE.
      RETURN
C
C     OBTAIN EIGENVECTORS AND MODESHAPES FOR SYSTEM WITH STATE FEEDBACK
C
 9804 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 354)
      IF (IAND .EQ. 1)  RETURN
      ISEL = 0
      IHALF = 0
      WRITE (2,8237)
      WRITE (6,8237)
      CALL EGVCTR (AMBKC, EIGCLR, EIGCLI, EX1, N, EX2, EX3, ANR, ANI,
     * LEX, MEX, 1, NMAX, ISEL, IHALF)
      IF (IPRT .EQ. 1)  GO TO 71
      IUNIT = 2
      WRITE (2,8236)
      CALL MATPRT (EX1, N, N, NMAX)
      IUNIT = 6
   71 CALL MODSHP (EX1, EX2, EIGCLI, N, NMAX)
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,867)
      CALL MATPRT (EX2, N, N, NMAX)
      IUNIT = 6
      RETURN
C
C     POSITIVE DEFINITENESS CHECK OF CONTROL RICCATI SOLUTION MATRIX, SS
C
 9805 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 355)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,8213)
      WRITE (2,8213)
      CALL EIGEN (SS, EIGR, EIGI, EX1, SSS, S, IA, IB, LEX, MEX, IBL,
     * IC, EX4, N, NMAX)
      RETURN
C
C     SYMMETRY CHECK OF CONTROL RICCATI SOLUTION MATRIX, SS
C
 9806 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 356)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,809)
      WRITE (6,809)
      DO 601  I = 1,N
      DO 601  J = 1,N
  601 EX1(J,I) = 0.0D0
      EAVG = 0.0D0
      EMAX = 0.0D0
      DO 602  I = 1,N
      IIP = I + 1
      EX1(I,I) = 0.0D0
      DO 602  J = IIP,N
      IF (SS(J,I) .EQ. 0.0D0)  GO TO 602
      EX1(J,I) = (SS(J,I) - SS(I,J)) / SS(J,I)
      IF (DABS(EX1(J,I)) .GE. DABS(EMAX))  EMAX = EX1(J,I)
      EAVG = EAVG + DABS(EX1(J,I))
  602 CONTINUE
      AN = N
      EAVG = 2.0D0 * EAVG / (AN * AN - AN)
      WRITE (6,606)
      CALL MATPRT (EX1, N, N, NMAX)
      WRITE (6,605)  EMAX
      WRITE (2,605)  EMAX
      WRITE (6,608)  EAVG
      WRITE (2,608)  EAVG
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,606)
      CALL MATPRT (EX1, N, N, NMAX)
      IUNIT = 6
      RETURN
C
C     RESIDUAL ERROR CHECK OF CONTROL RICCATI SOLUTION MATRIX, SS
C
 9807 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 357)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8214)
      WRITE (6,8214)
      CALL RICCHK (AAA1, SS, EX1, N, NMAX, NTOTMX)
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,8216)
      CALL MATPRT (EX1, N, N, NMAX)
      IUNIT = 6
      RETURN
C
C     STORE CONTROL RICCATI SOLUTION MATRIX SS IN A DATASET USING
C     UNIT 16
C
 9808 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 358)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8837)
      WRITE (6,8837)
      WRITE (16)  ((SS(I,J),  I = 1,N),  J = 1,N)
      RETURN
C
C     DESIGN A KALMAN FILTER
C
 9809 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 359)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8833)
      WRITE (6,8833)
      CALL ESTMAT (A, H, QQ, RRINV, KE, PP, CR, CI, X, TS2, XR, TT,
     * AAA2, EXT, AR, AI, LEX, MEX, ADBLE, N, NM, NTOT, 0, 0, NMAX,
     * NMMAX, NTOTMX)
      DO 6029  I = 1,450
      WHEN(I,4) = .TRUE.
      WHEN(I,6) = .TRUE.
      WHEN(I,10) = .TRUE.
 6029 WHEN(I,26) = .TRUE.
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,8228)
      CALL MATPRT (PP, N, N, NMAX)
      WRITE (2,8226)
      CALL MATPRT (KE, N, NM, NMAX)
      IUNIT = 6
      RETURN
C
C     STORE KALMAN FILTER GAIN MATRIX KE IN A DATASET USING UNIT 09
C
 9810 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 360)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8836)
      WRITE (6,8836)
      WRITE (9)  ((KE(I,J),  I = 1,N),  J = 1,NM)
      RETURN
C
C     OBTAIN EIGENVALUES OF OPTIMAL CONTROLLER (A - BKC - KEH)
C
 9811 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 361)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8080)
      WRITE (6,8080)
      CALL EIGEN (ABKCEH, ANR, ANI, EX1, SSS, S, IA, IB, LEX, MEX,
     * IBL, IC, EX4, N, NMAX)
      RETURN
C
C     OBTAIN EIGENVALUES OF CONTROL SYSTEM WITH A FILTER IN THE
C     FEEDBACK LOOP
C
 9812 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 362)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,808)
      WRITE (2,808)
      CALL EIGEN (ATOT, EIGRT, EIGIT, EXTOT1, SSSTOT, STOT, IA, IB, LEX,
     * MEX, IBL, IC, EXTOT4, NTOT, NTOTMX)
      RETURN
C
C     POSITIVE DEFINITENESS CHECK OF ERROR COVARIANCE MATRIX, PP
C
 9813 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 363)
      IF (IAND .EQ. 1)  RETURN
      WRITE (6,8215)
      WRITE (2,8215)
      CALL EIGEN (PP, EIGR, EIGI, EX1, SSS, S, IA, IB, LEX, MEX, IBL,
     * IC, EX4, N, NMAX)
      RETURN
C
C     SYMMETRY CHECK OF ERROR COVARIANCE MATRIX, PP
C
 9814 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 364)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,810)
      WRITE (6,810)
      DO 8018  I = 1,N
      DO 8018  J = 1,N
 8018 EX1(J,I) = 0.0D0
      EMAX = 0.0D0
      EAVG = 0.0D0
      DO 8015  I = 1,N
      IIP = I + 1
      EX1(I,I) = 0.0D0
      DO 8015  J = IIP,N
      IF (PP(J,I) .EQ. 0.0D0)  GO TO 8015
      EX1(J,I) = (PP(J,I) - PP(I,J)) / PP(J,I)
      IF (DABS(EX1(J,I)) .GE. DABS(EMAX))  EMAX = EX1(J,I)
      EAVG = EAVG + DABS(EX1(J,I))
 8015 CONTINUE
      AN = N
      EAVG = 2.0D0 * EAVG / (AN * AN - AN)
      WRITE (6,8014)
      CALL MATPRT (EX1, N, N, NMAX)
      WRITE (6,8016)  EMAX
      WRITE (2,8016)  EMAX
      WRITE (6,8019)  EAVG
      WRITE (2,8019)  EAVG
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,8014)
      CALL MATPRT (EX1, N, N, NMAX)
      IUNIT = 6
      RETURN
C
C     RESIDUAL ERROR CHECK OF ERROR COVARIANCE MATRIX, PP
C
 9815 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 365)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8219)
      WRITE (6,8219)
      CALL RICCHK (AAA2, PP, EX1, N, NMAX, NTOTMX)
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,8220)
      CALL MATPRT (EX1, N, N, NMAX)
      IUNIT = 6
      RETURN
C
C     STORE ERROR COVARIANCE MATRIX PP IN A DATASET USING UNIT 15
C
 9816 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 366)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8838)
      WRITE (6,8838)
      WRITE (15)  ((PP(I,J),  I = 1,N),  J = 1,N)
      RETURN
C
C     COMPUTE COVARIANCE MATRICES OF A LINEAR QUADRATIC REGULATOR WITH A
C     KALMAN FILTER IN THE FEEDBACK LOOP
C
 9817 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 367)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8834)
      WRITE (6,8834)
      CALL COVAR (A, B, H, C, DOUT, QQ, PP, KC, N, NM, NC, NO, XX, YY,
     * ZZ, UU, EX1, EX3, EX4, NMAX, NMMAX, NCMAX, NOMAX)
      DO 6030  I = 1,450
 6030 WHEN(I,27) = .TRUE.
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,8560)
      WRITE (2,8570)
      CALL MATPRT (UU, NC, NC, NCMAX)
      WRITE (2,8600)
      CALL MATPRT (XX, N, N, NMAX)
      WRITE (2,8610)
      CALL MATPRT (YY, NO, NO, NOMAX)
      WRITE (2,8630)
      CALL MATPRT (ZZ, NM, NM, NMMAX)
      IUNIT = 6
      RETURN
C
C     LYAPUNOV ERROR CHECK FOR NTH ORDER PROBLEM, SOLUTION GENERATED IN
C     FUNCTION NUMBER 817.
C
 9818 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 368)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8840)
      WRITE (6,8840)
      DO 430  J = 1,N
      DO 430  I = 1,N
      EX3(I,J) = QQ(I,J)
      AMBKC(I,J) = A(I,J)
      DO 430  K = 1,NC
      AMBKC(I,J) = AMBKC(I,J) - B(I,K) * KC(K,J)
      DO 430  L = 1,N
  430 EX3(I,J) = EX3(I,J) + B(I,K) * KC(K,L) * PP(L,J) + PP(I,L) *
     * KC(K,L) * B(J,K)
      CALL LYPCK (AMBKC, EX3, XX, EX1, EX2, SSS, ADBLET, N, NMAX)
      RETURN
C
C     FORM FEED-FORWARD MATRIX FOR NON-ZERO SET POINT CONTROL
C     KFF = - (CSP * AMBKC ** -1 * B) ** -1
C
 9819 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 369)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8843)
      WRITE (6,8843)
      DO 833  J = 1,N
      DO 833  I = 1,N
  833 EX3(I,J) = AMBKC(I,J)
      DO 1035  J = 1,N
      DO 1035  I = 1,N
      K = N * (J - 1) + I
 1035 ADBLE(K) = EX3(I,J)
      CALL MXINV (ADBLE, N, DET, LEX, MEX)
      DO 1036  J = 1,N
      DO 1036  I = 1,N
      K = N * (J - 1) + I
 1036 EX3(I,J) = ADBLE(K)
      IF (DET .EQ. 0.0D0)  WRITE (6,300)
      IF (DET .EQ. 0.0D0)  WRITE (2,300)
      WRITE (6,189)
      CALL MATPRT (EX3, N, N, NMAX)
      DO 88  J = 1,N
      DO 88  I = 1,N
      SUM = 0.0D0
      DO 87  K = 1,N
   87 SUM = EX3(I,K) * AMBKC(K,J) + SUM
   88 S(I,J) = SUM
      DO 822  J = 1,NC
      DO 822  I = 1,NC
      KFF(I,J) = 0.0D0
      DO 822  K = 1,N
      DO 822  L = 1,N
  822 KFF(I,J) = KFF(I,J) - CSP(I,K) * EX3(K,L) * B(L,J)
      DO 823  J = 1,NC
      DO 823  I = 1,NC
      K = NC * (J - 1) + I
  823 ADBLE(K) = KFF(I,J)
      CALL MXINV (ADBLE, NC, DET, LEX, MEX)
      DO 824  J = 1,NC
      DO 824  I = 1,NC
      K = NC * (J - 1) + I
  824 KFF(I,J) = ADBLE(K)
      IF (DET .NE. 0.0D0)  GO TO 825
      WRITE (2,8650)
      PAUSE
      RETURN
  825 WRITE (6,8680)
      CALL MATPRT (KFF, NC, NC, NCMAX)
      DO 6017  I = 1,450
 6017 WHEN(I,28) = .TRUE.
      IF (IPRT .EQ. 1)  RETURN
      IUNIT = 2
      WRITE (2,8680)
      CALL MATPRT (KFF, NC, NC, NCMAX)
      IUNIT = 6
      RETURN
C
C     STORE FEED FORWARD MATRIX KFF IN A DATASET USING UNIT 17
C
 9820 CONTINUE
      CALL PREREQ (WHEN, IFN, IAND, MZ, 370)
      IF (IAND .EQ. 1)  RETURN
      WRITE (2,8844)
      WRITE (6,8844)
      WRITE (17)  ((KFF(I,J),  I = 1,NC),  J = 1,NC)
      RETURN
C
C
C             FORMATS
C
C
   82 FORMAT (1X, 'EIGENVALUES OF SYSTEM WITH STATE FEEDBACK' / )
  189 FORMAT (1X, 'A-BKC INVERSE = ' )
  300 FORMAT (1X, 'AMBKC IS SINGULAR')
  605 FORMAT (1X, 'MAX. SYMMETRY ERROR IN SS = ', 1PE12.4)
  606 FORMAT (1X, 'SYMMETRY ERROR IN SS = ')
  608 FORMAT (1X, 'AVG. ABSOLUTE SYMMETRY ERROR IN SS = ', 1PE12.4)
  808 FORMAT (1X, 'EIGENVALUES OF CONTROL SYSTEM WITH A FILTER IN THE FE
     *EDBACK LOOP' / )
  809 FORMAT (1X, 'SYMMETRY CHECK OF CONTROL RICCATI SOLUTION MATRIX, SS
     *' / )
  810 FORMAT (1X, 'SYMMETRY CHECK OF ERROR COVARIANCE MATRIX, PP' / )
  867 FORMAT (1X, 'THE MATRIX OF MODE SHAPES IN MAG. AND ANGLE(DEG.) FOR
     *M' )
  868 FORMAT (1X, 'SS = ' )
 8014 FORMAT (1X, 'SYMMETRY ERROR IN PP = ')
 8016 FORMAT (1X, 'MAX. SYMMETRY ERROR IN PP = ', 1PE12.4)
 8019 FORMAT (1X, 'AVG. ABSOLUTE SYMMETRY ERROR IN PP = ', 1PE12.4)
 8080 FORMAT (1X, 'EIGENVALUES OF OPTIMAL CONTROLLER A-BKC-KEH' / )
 8213 FORMAT (1X, 'POSITIVE DEFINITENESS CHECK OF CONTROL RICCATI SOLUTI
     *ON MATRIX, SS ' / )
 8214 FORMAT (1X, 'RESIDUAL ERROR CHECK OF SS' / )
 8215 FORMAT (1X, 'POSITIVE DEFINITENESS CHECK OF ERROR COVARIANCE MATRI
     *X, PP' / )
 8216 FORMAT (1X, 'RESIDUAL ERROR MATRIX FOR CONTROL RICCATI EQUATION')
 8219 FORMAT (1X, 'RESIDUAL ERROR CHECK OF PP' / )
 8220 FORMAT (1X, 'RESIDUAL ERROR MATRIX FOR ESTIMATION RICCATI EQUATION
     * ')
 8226 FORMAT (1X, 'KE = ')
 8227 FORMAT (1X, 'KC = ')
 8228 FORMAT (1X, 'PP = ')
 8236 FORMAT (1X, 'MODIFIED EIGENVECTOR MATRIX OF AMBKC' )
 8237 FORMAT (1X, 'EIGENVECTORS AND MODE SHAPES WITH STATE FEEDBACK' / )
 8560 FORMAT (// 1X, '**************************************************
     *' / 15X, 'COVARIANCE MATRICES' / 1X, '****************************
     ***********************' ///)
 8570 FORMAT (1X, 'UU, CONTROL COVARIANCE MATRIX')
 8600 FORMAT (// 1X, 'XX, STATE COVARIANCE MATRIX')
 8610 FORMAT (// 1X, 'YY, OUTPUT COVARIANCE MATRIX')
 8630 FORMAT (// 1X, 'ZZ, MEASUREMENT COVARIANCE MATRIX')
 8650 FORMAT (1X, 'UNABLE TO FORM THE FEED FORWARD MATRIX, KFF')
 8680 FORMAT (1X, 'KFF = ')
 8832 FORMAT (1X, 'DESIGN A LINEAR QUADRATIC REGULATOR' / )
 8833 FORMAT (1X, 'DESIGN A KALMAN FILTER' / )
 8834 FORMAT (1X, 'COMPUTE COVARIANCE MATRICES FOR LINEAR QUADRATIC REGU
     *LATOR' / 1X, 'WITH KALMAN FILTER IN FEEDBACK LOOP' / )
 8835 FORMAT (1X, 'STORE OPTIMAL CONTROL GAINS (KC) ON UNIT 08.' / )
 8836 FORMAT (1X, 'STORE KALMAN FILTER GAINS (KE) ON UNIT 09' / )
 8837 FORMAT (1X, 'STORE CONTROL RICCATI SOLUTION MATRIX (SS) ON UNIT 16
     *' / )
 8838 FORMAT (1X, 'STORE ERROR COVARIANCE MATRIX (PP) ON UNIT 15' / )
 8840 FORMAT (1X, 'LYAPUNOV ERROR CHECK FOR FUNCTION 817' / )
 8843 FORMAT (1X, 'FORM FEED FORWARD MATRIX FOR NON-ZERO SET POINT CONTR
     *OL' / )
 8844 FORMAT (1X, 'STORE FEED FORWARD MATRIX (KFF) ON UNIT 17' / )
      END
      SUBROUTINE AES900 (IFN, IFUNC, IAND, MZ, IPRT, WHEN)
C
C     ******************************************************************
C
C     SUBROUTINE AES900 CONTAINS THOSE FUNCTIONS WHICH ARE SUPPLIED
C     BY THE USER.  AES900 DOES NOT CALL ANY SUBROUTINES.
C     AES900 IS CALLED BY MAIN PROGRAM AESOP.
C
C     INPUTS:
C
C              IFN     VECTOR OF FUNCTION NUMBERS TO BE DONE (1000)
C              IFUNC   FUNCTION NUMBER
C              MZ      WHICH FUNCTION IS TO BE DONE
C              IPRT    PRINT OPTION:  1, STANDARD PRINT;
C                                     2, EXTENDED PRINT
C              WHEN    LOGICAL MATRIX OF PREREQUISITES (450,50)
C
C     OUTPUTS:
C
C              IAND    DECISION VARIABLE:
C                      0, PREREQUISITES HAVE BEEN DONE;
C                      1, PREREQUISITES HAVE NOT BEEN DONE
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-S,U-Z)
      LOGICAL  WHEN
      DIMENSION  IFN(1000), WHEN(450,50)
C
C
C
      IFUNC = IFUNC - 900
      GO TO (9901,9902,9903,9904), IFUNC
C
C     NUMBERS 901, 902, 903, 904 AND ANY OTHERS THE USER
C     DESIRES TO ADD TO THE PROGRAM ARE NOT WRITTEN
C
 9901 CALL PREREQ (WHEN,IFN,IAND,MZ,401)
      IF (IAND .EQ. 1)  RETURN
      CALL UZR901
      RETURN
 9902 CALL PREREQ (WHEN,IFN,IAND,MZ,402)
      IF (IAND .EQ. 1)  RETURN
      CALL UZR902
      RETURN
 9903 CALL PREREQ (WHEN,IFN,IAND,MZ,403)
      IF (IAND .EQ. 1)  RETURN
      CALL UZR903
      RETURN
 9904 CALL PREREQ (WHEN,IFN,IAND,MZ,404)
      IF (IAND .EQ. 1)  RETURN
      CALL UZR904
      RETURN
      END
      SUBROUTINE ARRAY (IOPT,I,J,NROW,A)
C
C     ******************************************************************
C
C     SUBROUTINE ARRAY CONVERTS AN ARRAY FROM VECTOR TO MATRIX OR THE
C     REVERSE.  ARRAY DOES NOT CALL ANY SUBROUTINES.  ARRAY IS CALLED BY
C     SUBROUTINES COVAR, EGVCTR, EIGEN, LYPCK, RICSS, AND ZEROES.
C
C     INPUTS:
C
C              IOPT    OPTION INDICATING TYPE OF CONVERSION
C                      1 - FROM VECTOR TO MATRIX
C                      2 - FROM MATRIX TO VECTOR
C              I       NUMBER OF ROWS IN ACTUAL MATRIX
C              J       NUMBER OF COLUMNS IN ACTUAL MATRIX
C              NROW    NUMBER OF ROWS SPECIFIED FOR THE MATRIX A IN
C                      DIMENSION STATEMENT
C              A       IF MODE = 1, CONTAINS A VECTOR OF I*J LENGTH.
C                      IF MODE = 2, CONTAINS A MATRIX OF N BY J SIZE.
C
C     OUTPUTS:
C
C              A       IF MODE = 1, CONTAINS A MATRIX OF N BY J SIZE.
C                      IF MODE = 2, CONTAINS A VECTOR OF I*J LENGTH.
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1)
C
C
C
      NI = NROW - I
C
C     CHECK OPTION
C
      IF (IOPT - 1)  25,25,100
C
C        CONVERT FROM VECTOR TO MATRIX FORM
C
   25 IJ = I * J + 1
      NM = NROW * J + 1
      DO 50  K = 1,J
      NM = NM - NI
      DO 50  L = 1,I
      IJ = IJ - 1
      NM = NM - 1
   50 A(NM) = A(IJ)
      RETURN
C
C        CONVERT FROM MATRIX TO VECTOR FORM
C
  100 IJ = 0
      NM = 0
      DO 200  K = 1,J
      DO 150  L = 1,I
      IJ = IJ + 1
      NM = NM + 1
  150 A(IJ) = A(NM)
  200 NM = NM + NI
      RETURN
      END
      BLOCK DATA
C
C     ******************************************************************
C
C     BLOCK DATA FOR PLOTS
C
C     ******************************************************************
C
      COMMON /PLTLEG/ TRUN(4), TDAT(5)
      COMMON /LEGEND/ XLEG(6), YLEGM(6), YLEGA(6), NX, NYM, NYA
      COMMON /TITLES/ T1(15), T2(15), TNUM(50), T3(15), T4(15), T5(15),
     *T6(15), T7(15), T8(15), T9(15), T10(15), TB1(15), TB2(15), TB3(15)
      COMMON /TRTIT/ TTIT1(12), TTIT2(12), TTIT3(12), TTIT4(12),
     * TTIT5A(11), TTIT5B(11), TTIT5C(11), TUU(4), TXX(4), TYY(4),
     * TYSPD(4), TYSP(4)
      DATA TRUN / 'RUN ', 'NO. ', '    ', '    ' /
      DATA TDAT / 5 * '    ' /
      DATA XLEG / 'FREQ', 'UENC', 'Y,  ', 'HZ  ', 2 * '    ' /
      DATA YLEGM / 'AMPL', 'ITUD', 'E RA', 'TIO ', 2 * '    ' /
      DATA YLEGA / 'PHAS', 'E AN', 'GLE,', ' DEG', '.   ', '    ' /
      DATA NX / 16 /, NYM / 16 /, NYA / 16 /
      DATA TNUM / '   1', '   2', '   3', '   4', '   5', '   6',
     * '   7', '   8', '   9', '  10', '  11', '  12', '  13', '  14',
     * '  15', '  16', '  17', '  18', '  19', '  20', '  21', '  22',
     * '  23', '  24', '  25', '  26', '  27', '  28', '  29', '  30',
     * '  31', '  32', '  33', '  34', '  35', '  36', '  37', '  38',
     * '  39', '  40', '  41', '  42', '  43', '  44', '  45', '  46',
     * '  47', '  48', '  49', '  50' /
      DATA T1 / '    ', '   O', 'F OU', 'TPUT', '    ', '  TO', ' DIS',
     * 'TURB', 'ANCE', '    ', '    ', '    ', '    ', '    ', '    ' /
      DATA T2 / '    ', '  OF', ' CON', 'TROL', '    ', '  TO', ' DIS',
     * 'TURB', 'ANCE', '    ', '; ST', 'ATE ', 'FEED', 'BACK', '    ' /
      DATA T3 / '    ', '   O', 'F OU', 'TPUT', '    ', '    ', '  TO',
     * ' CON', 'TROL', '    ', '    ', '    ', '    ', '    ', '    ' /
      DATA T4 / '    ', '  OF', ' CON', 'TROL', '    ', '  TO', ' MEA',
     * 'SURE', 'MENT', '    ', ' FOR', ' OPT', '. CO', 'NTRO', 'LLER' /
      DATA T5 / '  OF', ' MEA', 'SURE', 'MENT', '    ', '  TO', ' DIS',
     * 'TURB', 'ANCE', '    ', ';KAL', 'MAN ', 'FILT', 'ER F', 'DBCK' /
      DATA T6 / '    ', '   O', 'F OU', 'TPUT', '    ', '  TO', ' DIS',
     * 'TURB', 'ANCE', '    ', ';KAL', 'MAN ', 'FILT', 'ER F', 'DBCK' /
      DATA T7 / '    ', '  OF', ' CON', 'TROL', '    ', '  TO', ' DIS',
     * 'TURB', 'ANCE', '    ', ';KAL', 'MAN ', 'FILT', 'ER F', 'DBCK' /
      DATA T8 / '  OF', ' MEA', 'SURE', 'MENT', '    ', '  TO', ' DIS',
     * 'TURB', 'ANCE', '    ', '    ', '    ', '    ', '    ', '    ' /
      DATA T9 / '    ', '   O', 'F OU', 'TPUT', '    ', '  TO', ' DIS',
     * 'TURB', 'ANCE', '    ', '; ST', 'ATE ', 'FEED', 'BACK', '    ' /
      DATA T10 / '  OF', ' MEA', 'SURE', 'MENT', '    ', '    ', '  TO',
     * ' CON', 'TROL', '    ', '    ', '    ', '    ', '    ', '    ' /
      DATA TB1 / 'OPEN', ' LOO', 'P FR', 'EQUE', 'NCY ', 'RESP', 'ONSE',
     * 8 * '    ' /
      DATA TB2 / 'CLOS', 'ED L', 'OOP ', 'FREQ', 'UENC', 'Y RE', 'SPON',
     * 'SE  ', 7 * '    ' /
      DATA TB3 /  'FREQ', 'UENC', 'Y RE', 'SPON', 'SE  ', 10 * '    ' /
      DATA  TTIT1 / 'STEP', ' RES', 'PONS', 'ES F', 'OR N', 'ON-Z',
     *'ERO ', 'SET-', 'POIN', 'T RE', 'G.  ', '    ' /
      DATA  TTIT2 / 'OPEN', ' LOO', 'P ST', 'EP R', 'ESPO', 'NSES',
     * 6 * '    '  /
      DATA  TTIT3 / 'I.C.', ' RES', 'PONS', 'ES F', 'OR L', 'INEA',
     * 'R QU', 'ADRA', 'TIC ', 'REGU', 'LATO', 'R   ' /
      DATA  TTIT4 / 'OPEN', ' LOO', 'P IN', 'ITIA', 'L CO', 'NDIT',
     * 'ION ', 'RESP', 'ONSE', 'S   ', 2 * '    ' /
      DATA  TTIT5A / 'INPU', 'T:  ', 'SET ', 'POIN', 'T CO', 'MMAN',
     * 'D   ', 4 * '    ' /
      DATA  TTIT5B / 5 * '    ', 'INPU', 'T:  ', 4 * '    ' /
      DATA  TTIT5C / '    ', 'INIT', 'IAL ', 'COND', 'ITIO', 'N ON',
     * ':   ', 4 * '    ' /
      DATA TUU / '   U', '   (', '    ', '   )' /
      DATA TXX / '   X', '   (', '    ', '   )' /
      DATA TYY / '   Y', '   (', '    ', '   )' /
      DATA TYSPD / 'YSPD', '   (', '    ', '   )' /
      DATA TYSP / ' YSP', '   (', '    ', '   )' /
      END
      SUBROUTINE BODE (FRQ, A1, A2, PHI1, PHI2, TTITL, TB, NPTS, KI,
     * AMP, PHA, SETAP, KTYPE1, KTYPE2, IP, NAME, IONPLT)
C
C     ******************************************************************
C
C     SUBROUTINE BODE MAKES PLOTS OF FREQUENCY RESPONSES.  AMP, PHA AND
C     SETAP MUST BE SINGLE PRECISION BECAUSE OF THE PLOT SUBROUTINES.
C     BODE CALLS PLOTTING SUBROUTINES ONLY.  BODE IS CALLED BY
C     SUBROUTINE AES500.
C
C     INPUTS:
C
C              FRQ     VECTOR OF FREQUENCY
C                      (DIMENSION IS LESS THAN OR EQUAL TO 500)
C              A1      VECTOR OF AMPLITUDE FOR 1ST CURVE
C                      (DIMENSION IS LESS THAN OR EQUAL TO 500)
C              A2      VECTOR OF AMPLITUDE FOR 2ND CURVE, IF DESIRED
C                      (DIMENSION IS LESS THAN OR EQUAL TO 500)
C              PHI1    VECTOR OF PHASE FOR 1ST CURVE
C                      (DIMENSION IS LESS THAN OR EQUAL TO 500)
C              PHI2    VECTOR OF PHASE FOR 2ND CURVE, IF DESIRED
C                      (DIMENSION IS LESS THAN OR EQUAL TO 500)
C              TTITL   TITLE OF PLOT
C                      (DIMENSION IS GREATER THAN OR EQUAL TO 15)
C              TB      TITLE OF PLOT
C                      (DIMENSION IS GREATER THAN OR EQUAL TO 15)
C              NPTS    NUMBER OF POINTS PER CURVE
C                      (LESS THAN OR EQUAL TO 500)
C              KI      1, IF ONE CURVE PER PLOT
C                      2, IF TWO CURVES PER PLOT
C              KTYPE1) THESE TWO VARIABLES DEFINE WHETHER
C                    ) THE PLOT IS TO BE LINEAR,
C              KTYPE2) LOG, OR SEMI-LOG
C              IP      PLOT ENTITY INDEX (USED BY PLOTSUBS ONLY)
C                      INCREASES BY ONE FOR EACH FRAME
C              NAME    NAME OF PLOT DATASET (9) (USED BY PLOTSUBS ONLY)
C                      (PARTITIONED DATASET THAT HOLDS PLOT ENTITIES)
C              IONPLT  0, IF OFFLINE PLOTS
C                      1, IF ONLINE PLOTS
C
C     OUTPUTS:
C
C              AMP     STORAGE VECTOR OF AMPLITUDES FOR 1 OR 2 CURVES
C                      (DIMENSION IS LESS THAN OR EQUAL TO 1000)
C              PHA     STORAGE VECTOR OF PHASES FOR 1 OR 2 CURVES
C                      (DIMENSION IS LESS THAN OR EQUAL TO 1000)
C              IP      PLOT ENTITY INDEX (USED BY PLOTSUBS ONLY)
C                      INCREASES BY ONE FOR EACH FRAME
C
C     TEMPORARY STORAGE:
C
C              SETAP   VECTOR
C                      (DIMENSION IS LESS THAN OR EQUAL TO 500)
C
C     ******************************************************************
C
      REAL*8 FRQ, A1, A2, PHI1, PHI2
      INTEGER*2  INPTS, INPTS1
      LOGICAL*1  IX / .TRUE. /
      LOGICAL*1  IY / .FALSE. /
      COMMON /PLTLEG/ TRUN(4), TDAT(5)
      COMMON /LEGEND/ XLEG(6), YLEGM(6), YLEGA(6), NX, NYM, NYA
      DIMENSION  FRQ(1), AMP(1), PHA(1), A1(1), A2(1), PHI1(1), PHI2(1),
     * SETAP(1), TTITL(1), TB(1)
      DIMENSION  NAME(9), VARSX(8), VARSY(8), TNARR(2), IVARS(20),
     * YLEG(30), TCLOOP(4), TOLOOP(4)
      DIMENSION FR(500)
      DATA  TOLOOP / Z40414040, 'OPEN', ' LOO', 'P   ' /
      DATA  TCLOOP / Z403E4040, 'CLOS', 'ED L', 'OOP ' /
C
C
C
      DO 10  J = 1,6
   10 YLEG(J) = YLEGM(J)
      IVARS(1) = 7
      IVARS(2) = NPTS
      IVARS(3) = 2
      IVARS(4) = 62
      IVARS(5) = 10
      IVARS(6) = 15
      IVARS(7) = 1
      INPTS = NPTS
      INPTS1 = NPTS
      IF (KI .EQ. 2)  INPTS1 = 2 * NPTS
      IP = IP + 2
      IP1 = IP - 1
      DO 20  J = 1,NPTS
      JJ = J + NPTS
      SETAP(J) = A1(J)
      FR(J) = FRQ(J)
      AMP(J) = A1(J)
      PHA(J) = PHI1(J)
      AMP(JJ) = A2(J)
   20 PHA(JJ) = PHI2(J)
      VARSX(1) = 8.0
      VARSY(1) = 8.0
      VARSX(8) = -1.0
      VARSY(8) = -1.0
      VARSX(2) = 5.0
      VARSY(2) = 7.0
      VARSX(3) = 0.0
      VARSY(3) = 90.0
      VARSX(6) = 10.0
      VARSY(6) = 10.0
      VARSX(7) = 2.0
      VARSY(7) = 2.0
      CALL SCLBAK (IX, INPTS, FR, TNARR)
      IF (KTYPE1 .NE. 2 .AND. KTYPE1 .NE. 3)
     * CALL GINTVL (TNARR(1), TNARR(2), 10, 0, TXMIN, TXMAX)
      IF (KTYPE1 .EQ. 2 .OR. KTYPE1 .EQ. 3)
     * CALL LOGSET (TXMIN, TXMAX, TNARR, INT)
      VARSX(4) = TXMIN
      VARSX(5) = TXMAX
      IF (KTYPE1 .EQ. 2 .OR. KTYPE1 .EQ. 3)  VARSX(6) = - INT
      CALL SCLBAK (IY, INPTS1, AMP, TNARR)
      IF (KTYPE1 .NE. 1 .AND. KTYPE1 .NE. 3)
     * CALL GINTVL (TNARR(1), TNARR(2), 10, 1, TYMIN, TYMAX)
      IF (KTYPE1 .EQ. 1 .OR. KTYPE1 .EQ. 3)
     * CALL LOGSET (TYMIN, TYMAX, TNARR, INT)
      VARSY(4) = TYMIN
      VARSY(5) = TYMAX
      IF (KTYPE1 .EQ. 1 .OR. KTYPE1 .EQ. 3)  VARSY(6) = - INT
      CALL BEGID (IP)
      CALL BEGID (IP1)
      CALL XAXIS (1.0, 1.0, VARSX)
      CALL YAXIS (1.0, 1.0, VARSY)
      CALL SCISS (3)
      CALL GPLOT (FR, SETAP, IVARS)
      IF (KI .EQ. 1)  GO TO 40
      CALL CHARS (16, TOLOOP, 0.0, 5.0, 7.8, 10)
      CALL CHARS (16, TCLOOP, 0.0, 5.0, 7.6, 10)
      DO 30  J = 1,NPTS
      JJ = J + NPTS
   30 SETAP(J) = AMP(JJ)
      IVARS(4) = 65
      CALL GPLOT (FR, SETAP, IVARS)
   40 CONTINUE
      CALL TITLE (3, NYM, 10, YLEG)
      CALL TITLE (4, NX, 10, XLEG)
      CALL ENDID (IP1, 3, NAME)
      CALL CHARS (30, TB, 0.0, 1.2, 8.6, 10)
      CALL CHARS (60, TTITL, 0.0, 1.2, 8.4, 10)
      CALL CHARS (20, TDAT, 0.0, 4.0, 8.2, -10)
      CALL CHARS (16, TRUN, 0.0, 4.0, 8.0, -10)
      CALL ENDID (IP, -1, NAME)
      CALL DISPLA (1)
      IF (IONPLT .EQ. 1)  PAUSE
      IP = IP + 2
      IP1 = IP - 1
      DO 50  J = 1,6
   50 YLEG(J) = YLEGA(J)
      DO 60  J = 1,NPTS
   60 SETAP(J) = PHA(J)
      IVARS(4) = 62
      VARSX(6) = 10.0
      VARSY(6) = 10.0
      CALL SCLBAK (IX, INPTS, FR, TNARR)
      IF (KTYPE2 .NE. 2 .AND. KTYPE2 .NE. 3)
     * CALL GINTVL (TNARR(1), TNARR(2), 10, 0, TXMIN, TXMAX)
      IF (KTYPE2 .EQ. 2 .OR. KTYPE2 .EQ. 3)
     * CALL LOGSET (TXMIN, TXMAX, TNARR, INT)
      VARSX(4) = TXMIN
      VARSX(5) = TXMAX
      IF (KTYPE2 .EQ. 2 .OR. KTYPE2 .EQ. 3)  VARSX(6) = - INT
      CALL SCLBAK (IY, INPTS1, PHA, TNARR)
      IF (KTYPE2 .NE. 1 .AND. KTYPE2 .NE. 3)
     * CALL GINTVL (TNARR(1), TNARR(2), 10, 1, TYMIN, TYMAX)
      IF (KTYPE2 .EQ. 1 .OR. KTYPE2 .EQ. 3)
     * CALL LOGSET (TYMIN, TYMAX, TNARR, INT)
      VARSY(4) = TYMIN
      VARSY(5) = TYMAX
      IF (KTYPE2 .EQ. 1 .OR. KTYPE2 .EQ. 3)  VARSY(6) = - INT
      CALL BEGID (IP)
      CALL BEGID (IP1)
      CALL XAXIS (1.0, 1.0, VARSX)
      CALL YAXIS (1.0, 1.0, VARSY)
      CALL SCISS (3)
      CALL GPLOT (FR, SETAP, IVARS)
      IF (KI .EQ. 1)  GO TO 80
      CALL CHARS (16, TOLOOP, 0.0, 5.0, 7.8, 10)
      CALL CHARS (16, TCLOOP, 0.0, 5.0, 7.6, 10)
      DO 70  J = 1,NPTS
      JJ = J + NPTS
   70 SETAP(J) = PHA(JJ)
      IVARS(4) = 65
      CALL GPLOT (FR, SETAP, IVARS)
   80 CONTINUE
      CALL TITLE (3, NYA, 10, YLEG)
      CALL TITLE (4, NX, 10, XLEG)
      CALL ENDID (IP1, 3, NAME)
      CALL CHARS (30, TB, 0.0, 1.2, 8.6, 10)
      CALL CHARS (60, TTITL, 0.0, 1.2, 8.4, 10)
      CALL CHARS (20, TDAT, 0.0, 4.0, 8.2, -10)
      CALL CHARS (16, TRUN, 0.0, 4.0, 8.0, -10)
      CALL ENDID (IP, -1, NAME)
      CALL DISPLA (1)
      IF (IONPLT .EQ. 1)  PAUSE
      RETURN
      END
      SUBROUTINE BOLLIN (A, AS, B, C, X, Y, Z1, Z2, Z3, N, NMAX)
C
C     ******************************************************************
C
C     SUBROUTINE BOLLIN CONVERTS X(DOT)=AX+BU,Y=C(TRANSPOSE)X TO
C     TRANSFER FUNCTION Y/U=Z2/Z1 RATIO OF POLYNOMIALS.
C     BOLLIN CALLS SUBROUTINES DAVISO AND DANSKY.  BOLLIN IS CALLED BY
C     SUBROUTINE FRSPNS.
C
C     INPUTS:
C
C              A       SYSTEM MATRIX (N,N)
C              B       SYSTEM VECTOR (N)
C              C       SYSTEM VECTOR (N)
C              N       ACTUAL SIZE OF MATRIX A
C              NMAX    MAXIMUM SIZE OF N
C
C     OUTPUTS:
C
C              Z1      DENOMINATOR COEFFICIENT VECTOR (N)
C              Z2      NUMERATOR COEFFICIENT VECTOR (N)
C              Z3      NUMERATOR COEFFICIENT VECTOR (N)
C
C     TEMPORARY STORAGE:
C
C              AS      MATRIX (N,N)
C              X       VECTOR (N)
C              Y       VECTOR (N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(NMAX,1), AS(NMAX,1), B(1), C(1), X(1), Y(1)
      DIMENSION Z1(1), Z2(1), Z3(1)
C
C     TRANSFORM Z=TX TO MAKE OUTPUT A STATE
C
      CALL DAVISO (A, B, C, N, NMAX, MC)
C
C     SAVE A USING AS
C
      DO 20  K = 1,N
      DO 10  J = 1,N
   10 AS(K,J) = A(K,J)
   20 CONTINUE
C
C     FIND DEN CHAR EQN COEF'S
C
      CALL DANSKY (AS, X, Y, Z1, N, NMAX)
C
C     SET AS=A AGAIN AND OVER WRITE A(K,MC) COLUMN WITH -B
C
      DO 40  K = 1,N
      DO 30  J = 1,N
   30 AS(K,J) = A(K,J)
   40 AS(K,MC) = - B(K)
C
C     FIND FIRST PART OF NUM CHAR EQN
C
      CALL DANSKY (AS, X, Y, Z2, N, NMAX)
C
C     SET AS=A AGAIN; COLLAPSE MC ROW AND COLUMN
C
      NM1 = N - 1
      DO 60  K = 1,NM1
      K1 = K
      IF (K .GE. MC)  K1 = K + 1
      DO 50  J = 1,NM1
      J1 = J
      IF (J .GE. MC)  J1 = J + 1
   50 AS(K,J) = A(K1,J1)
   60 CONTINUE
C
C     FIND SECOND PART OF NUM CHAR EQN
C
      CALL DANSKY (AS, X, Y, Z3, NM1, NMAX)
C
C     SUBSTRACT FIRST PART FROM SECOND PART
C
      DO 100  J = 1,NM1
  100 Z2(J) = Z2(J) - Z3(J)
      RETURN
      END
      SUBROUTINE CONDI (VARO, SS, S, IN, JBL, IOR, NBL, IBL, IC, D,
     * IOP1, N, NMAX)
C
C     ******************************************************************
C
C     SUBROUTINE CONDI CHANGES CONDITION OF A MATRIX BY PUTTING IT IN
C     BLOCK DIAGONAL FORM (IF REDUCIBLE) AND THEN SCALING.
C     CONDI CALLS SUBROUTINES REDU AND SCALEA.  CONDI IS CALLED BY
C     SUBROUTINES EIGEN AND ZEROES.
C
C     INPUTS:
C
C              VARO    MATRIX TO BE CONDITIONED (N,N)
C              IOP1    PRINT OPTION; 0 NO PRINT, 1 PRINT
C              N       ACTUAL SIZE OF MATRIX VARO
C              NMAX    MAXIMUM SIZE OF N
C
C     OUTPUTS:
C
C              S       CONDITIONED MATRIX (N,N)
C              IOR     BLOCK-DIAGONALIZING PERMUTATION INTEGER
C                      VECTOR (N)
C              NBL     INTEGER VECTOR OF SIZES OF EACH IRREDUCIBLE
C                      BLOCK (N)
C              D       VECTOR OF DIAGONAL ELEMENTS OF DIAGONAL SCALING
C                      MATRIX (N)
C
C     TEMPORARY STORAGE:
C
C              SS      MATRIX (N,N)
C              IN      INTEGER VECTOR (N)
C              JBL     INTEGER VECTOR (N)
C              IBL     INTEGER VECTOR (N)
C              IC      INTEGER VECTOR (N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  VARO(NMAX,1), SS(NMAX,1), S(NMAX,1), IN(1), JBL(1),
     * IOR(1), NBL(1), IBL(1), IC(1), D(1)
C
C
C
      CALL REDU (VARO, SS, S, IN, JBL, INBL, IOR, IC, NBL, IBL, N, NMAX)
      DO 10  I = 1,N
   10 D(I) = 1.0
      NSUM = 0
      DO 30  K = 1,INBL
      NSMOLD = NSUM + 1
      NSUM = NBL(K) + NSUM
      IF (NBL(K) .LE. 1)  GO TO 30
      DO 20  J = NSMOLD,NSUM
      JJ = J - NSMOLD + 1
      DO 20  I = NSMOLD,NSUM
      II = I - NSMOLD + 1
   20 SS(II,JJ) = S(I,J)
      CALL SCALEA (SS, D(NSMOLD), NBL(K), IOP1, NMAX)
   30 CONTINUE
      DO 40  J = 1,N
      DO 40  I = 1,N
   40 S(I,J) = S(I,J) * D(J) / D(I)
      RETURN
      END
      SUBROUTINE CONTRL (AA, BB, QC, NN, PCINV, KC, SS, CR, CI, X, TS,
     * XR, TT, AAA, EXT, AR, AI, IPER, IPERN, ADBLE, N, NC, N2, IOP1,
     * IOP2, NMAX, NCMAX, N2MAX)
C
C     ******************************************************************
C
C     SUBROUTINE CONTRL SOLVES THE OPTIMAL LINEAR REGULATOR PROBLEM.  IT
C     SETS UP AN N2 BY N2 MATRIX AAA, USING MATRICES AA, BB, QC, NN, AND
C     PCINV.  CONTRL OBTAINS THE SOLUTION TO THE RICCATI EQUATION, SS,
C     AND THEN COMPUTES THE CONTROL GAINS, KC.  CONTRL CALLS SUBROUTINES
C     MATPRT AND RICSS.  CONTRL IS CALLED BY SUBROUTINE AES800.
C
C     INPUTS:
C
C              AA      SYSTEM MATRIX (N,N)
C              BB      CONTROL INPUT MATRIX (N,NC)
C              QC      STATE WEIGHTING MATRIX (N,N)
C              NN      STATE-CONTROL PRODUCT WEIGHTING MATRIX (N,NC)
C              PCINV   INVERSE OF CONTROL WEIGHTING MATRIX (NC,NC)
C              IOP1    SCALING PRINT OPTION: 0, NO PRINT; 1, PRINT
C              IOP2    EIGENVECTOR PRINT OPTION: 0, NO PRINT; 1, PRINT
C              N       NUMBER OF STATE VARIABLES
C              NC      NUMBER OF CONTROL INPUTS
C              N2      DIMENSION OF HAMILTONIAN MATRIX, 2 X N
C              NMAX    MAXIMUM SIZE OF N
C              NCMAX   MAXIMUM SIZE OF NC
C              N2MAX   MAXIMUM SIZE OF N2
C
C     OUTPUTS:
C
C              KC      CONTROL GAIN MATRIX (NC,N)
C              SS      LQR RICCATI SOLUTION MATRIX (N,N)
C              CR      VECTOR OF REAL PARTS OF EIGENVALUES (N2)
C                            (OF AAA)
C              CI      VECTOR OF IMAGINARY PARTS OF EIGENVALUES (N2)
C                            (OF AAA)
C              X       MODIFIED EIGENVECTOR MATRIX OF AAA (N2,N2)
C              TS      SCALING TRANSFORMATION VECTOR OF AAA (N2)
C              AAA     HAMILTONIAN MATRIX FOR LQR RICCATI
C                      EQUATION (N2,N2)
C
C     TEMPORARY STORAGE:
C
C              XR      MATRIX (N2,N2)
C              TT      MATRIX (N2,N2)
C              EXT     MATRIX (N2,N2)
C              AR      VECTOR (N2)
C              AI      VECTOR (N2)
C              IPER    INTEGER VECTOR (N2)
C              IPERN   INTEGER VECTOR (N2)
C              ADBLE   VECTOR (N X N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A,B,D-H,O-Z)
      REAL*8 NN, KC
      REAL*8 CR,CI
      COMMON /PRTOP/ IUNIT
      DIMENSION  AA(NMAX,1), BB(NMAX,1), QC(NMAX,1), NN(NMAX,1),
     * PCINV(NCMAX,1), KC(NCMAX,1), SS(NMAX,1), CR(1), CI(1),
     * X(N2MAX,1), TS(1), XR(N2MAX,1), TT(N2MAX,1), AAA(N2MAX,1),
     * EXT(N2MAX,1), AR(1), AI(1), IPER(1), IPERN(1), ADBLE(1)
C
C
C
      WRITE (6,100)
C
C     FORM AAA MATRIX
C
      DO 20  J = 1,N
      JJ = J + N
      DO 20  I = 1,N
      II = I + N
      SUM1 =  - AA(I,J)
      SUM2 = QC(I,J)
      SUM3 = 0.0D0
      DO 10  K = 1,NC
      DO 10  L = 1,NC
      SUM1 = SUM1 + BB(I,K) * PCINV(K,L) * NN(J,L)
      SUM2 = SUM2 - NN(I,K) * PCINV(K,L) * NN(J,L)
   10 SUM3 = SUM3 + BB(I,K) * PCINV(K,L) * BB(J,L)
      AAA(I,J) = SUM1
      AAA(JJ,II) =  - SUM1
      AAA(II,J) = SUM2
   20 AAA(I,JJ) = SUM3
C
C     OBTAIN SOLUTION TO CONTROL RICCATI EQ. AND STORE IN SS
C
      CALL RICSS (AAA, X, SS, CR, CI, TS, XR, EXT, TT, IPER, IPERN, AR,
     * AI, ADBLE, IOP1, IOP2, N, N2, NMAX, N2MAX)
      WRITE (6,130)
      IUNIT = 6
      CALL MATPRT (SS, N, N, NMAX)
C
C     COMPUTE CONTROL GAIN MATRIX KC
C
   50 DO 70  I = 1,NC
      DO 70  J = 1,N
      SUM1 = 0.0D0
      DO 60  K = 1,NC
      SUM1 = SUM1 + PCINV(I,K) * NN(J,K)
      DO 60  L = 1,N
   60 SUM1 = SUM1 + PCINV(I,K) * BB(L,K) * SS(L,J)
   70 KC(I,J) = SUM1
      WRITE (6,160)
      IUNIT = 6
      CALL MATPRT (KC, NC, N, NCMAX)
      RETURN
C
C
C     FORMATS
C
C
  100 FORMAT (1H0 / 1X, '***********************************************
     **********************************' / 15X, 'RESULTS OF LINEAR QUADR
     *ATIC REGULATOR DESIGN PROBLEM' / 1X, '****************************
     *****************************************************' ///)
  130 FORMAT (// 1X, 'SS, MATRIX RICCATI SOLUTION FOR LQR PROBLEM')
  160 FORMAT (// 1X, 'KC, THE CONTROL GAIN MATRIX')
      END
      SUBROUTINE COVAR (AA, BB, HH, CC, DOUT, QQ, PP, KC, N, NM, NC, NO,
     * XX, YY, ZZ, UU, A, Q, WORK, NMAX, NMMAX, NCMAX, NOMAX)
C
C     *****************************************************************
C
C     SUBROUTINE COVAR SETS UP MATRICES FOR SUBROUTINE LAPNV (LYAPUNOV
C     EQUATION) WHICH IS THEN CALLED TO OBTAIN STATE COVARIANCE MATRIX,
C     XX.  XX, KALMAN FILTER ERROR COVARIANCE PP, AND CONTROL GAINS KC
C     ARE USED TO OBTAIN CONTROL COVARIANCE - UU, OUTPUT COVARIANCE
C     - YY, AND MEASUREMENT COVARIANCE - ZZ.  COVAR CALLS SUBROUTINES
C     ARRAY, LAPNV, AND MATPRT.  COVAR IS CALLED BY SUBROUTINE AES800.
C
C     INPUTS:
C
C              AA      SYSTEM MATRIX (N,N)
C              BB      CONTROL INPUT MATRIX (N,NC)
C              HH      MEASUREMENT MATRIX (NM,N)
C              CC      OUTPUT MATRIX (NO,N)
C              DOUT    FEED FORWARD MATRIX (NO,NC)
C              QQ      POWER SPECTRAL DENSITY MATRIX (N,N)
C                      (OF PLANT DISTURBANCE)
C              PP      KALMAN FILTER ERROR COVARIANCE MATRIX (N,N)
C              KC      CONTROL GAIN MATRIX (NC,N)
C              N       NUMBER OF STATE VARIABLES
C              NM      NUMBER OF MEASUREMENTS
C              NC      NUMBER OF CONTROL INPUTS
C              NO      NUMBER OF OUTPUTS
C              NMAX    MAXIMUM SIZE OF N
C              NMMAX   MAXIMUM SIZE OF NM
C              NCMAX   MAXIMUM SIZE OF NC
C              NOMAX   MAXIMUM SIZE OF NO
C
C     OUTPUTS:
C
C              XX      STATE COVARIANCE MATRIX (N,N)
C              YY      OUTPUT COVARIANCE MATRIX (NO,NO)
C              ZZ      MEASUREMENT COVARIANCE MATRIX (NM,NM)
C              UU      CONTROL COVARIANCE MATRIX (NC,NC)
C
C     TEMPORARY STORAGE:
C
C              A       MATRIX (N,N)
C              Q       MATRIX (N,N)
C              WORK    VECTOR (N)
C
C     *****************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8  KC
      DIMENSION  AA(NMAX,1), BB(NMAX,1), HH(NMMAX,1), CC(NOMAX,1),
     * DOUT(NOMAX,1), QQ(NMAX,1), PP(NMAX,1), KC(NCMAX,1), XX(NMAX,1),
     * YY(NOMAX,1), ZZ(NMMAX,1), UU(NCMAX,1), A(NMAX,1), Q(NMAX,1),
     * WORK(1)
C
C
C
      WRITE (6,260)
C
C     FORM COEFFICIENT MATRICES FOR LYAPUNOV EQUATION WHOSE SOLUTION
C     IS STATE COVARIANCE MATRIX
C
      WORK(1) = 1.D-6
      QIN = .1D0
      DO 20  J = 1,N
      DO 20  I = 1,N
      SUM1 = AA(I,J)
      SUM2 = QQ(I,J)
      DO 10  K = 1,NC
      SUM1 = SUM1 - BB(I,K) * KC(K,J)
      DO 10  L = 1,N
   10 SUM2 = SUM2 + BB(I,K) * KC(K,L) * PP(L,J) + PP(I,L) * KC(K,L) *
     *BB(J,K)
      A(I,J) = SUM1
   20 Q(I,J) = SUM2
C
C     OBTAIN STATE COVARIANCE MATRIX AND STORE IN XX
C
      CALL ARRAY (2, N, N, NMAX, A)
      CALL ARRAY (2, N, N, NMAX, Q)
      CALL LAPNV (A, XX, Q, QIN, N, WORK)
      CALL ARRAY (1, N, N, NMAX, XX)
C
C     OBTAIN COVARIANCE MATRICES FOR VARIABLES U(CONTROL),
C     Z(MEASUREMENT), & Y(OUTPUT)
C
      DO 25  I = 1,NO
      DO 25  K = 1,N
      DO 25  M1 = 1,NC
   25 Q(I,K) = CC(I,K) - DOUT(I,M1) * KC(M1,K)
      DO 30  J = 1,NO
      DO 30  I = 1,NO
      YY(I,J) = 0.0D0
      DO 30  K = 1,N
      DO 30  L = 1,N
   30 YY(I,J) = YY(I,J) + CC(I,K) * PP(K,L) * CC(J,L) +
     *(Q(I,K) * (XX(K,L) - PP(K,L)) * Q(J,L))
      DO 60  J = 1,NM
      DO 60  I = 1,NM
      ZZ(I,J) = 0.0D0
      DO 60  K = 1,N
      DO 60  L = 1,N
   60 ZZ(I,J) = ZZ(I,J) + HH(I,K) * XX(K,L) * HH(J,L)
      DO 80  J = 1,NC
      DO 80  I = 1,NC
      SUM1 = 0.0D0
      DO 70  K = 1,N
      DO 70  L = 1,N
   70 SUM1 = SUM1 + KC(I,K) * (XX(K,L) - PP(K,L)) * KC(J,L)
   80 UU(I,J) = SUM1
      WRITE (6,270)
      CALL MATPRT (UU, NC, NC, NCMAX)
      WRITE (6,300)
      CALL MATPRT (XX, N, N, NMAX)
      WRITE (6,310)
      CALL MATPRT (YY, NO, NO, NOMAX)
      WRITE (6,330)
      CALL MATPRT (ZZ, NM, NM, NMMAX)
      RETURN
C
C
C     FORMATS
C
C
  260 FORMAT (1H0 / 1X, '***********************************************
     ****' / 15X, 'COVARIANCE MATRICES' / 1X, '*************************
     **************************' ///)
  270 FORMAT (1X, 'UU, CONTROL COVARIANCE MATRIX')
  300 FORMAT (// 1X, 'XX, STATE COVARIANCE MATRIX')
  310 FORMAT (// 1X, 'YY, OUTPUT COVARIANCE MATRIX')
  330 FORMAT (// 1X, 'ZZ, MEASUREMENT COVARIANCE MATRIX')
      END
      SUBROUTINE CTBL (B, CI, T, TINV, TINVB, EX1, ADBLE, LEX, MEX, N,
     * NC, NMAX)
C
C     ******************************************************************
C
C     SUBROUTINE CTBL COMPUTES THE (RELATIVE) CONTROLLABILITY OF A
C     LINEAR SYSTEM DESCRIBED BY XDOT=A*X + B*U.
C     NOTE: FOR A COMPLEX EIGENVALUE PAIR, THE CORRESPONDING TWO COLUMN
C     ELEMENTS IN TINVB ARE STORED AS MAGNITUDE AND ANGLE (IN DEGREES)
C     RESPECTIVELY.
C     CTBL CALLS SUBROUTINES MATPRT AND MXINV.  CTBL IS CALLED BY
C     SUBROUTINE AES400.
C
C     INPUTS:
C
C              B       SYSTEM INPUT MATRIX B (N,NC)
C              CI      VECTOR OF IMAG PARTS OF THE EIGENVALUES (N)
C                      (OF MATRIX A)
C              T       MODIFIED EIGENVECTOR MATRIX OF MATRIX A (N,N)
C              N       NUMBER OF STATES
C              NC      NUMBER OF INPUTS
C              NMAX    MAXIMUM SIZE OF N
C
C     OUTPUTS:
C
C              TINV    INVERSE OF MATRIX T (N,N)
C              TINVB   CONTROL EFFECTIVENESS MATRIX (N,NC)
C                      (IN MAGNITUDE AND PHASE ANGLE FORM)
C              EX1     TINV*B WHERE TINV IS IN MODIFIED FORM (N,NC)
C
C     TEMPORARY STORAGE:
C
C              ADBLE   VECTOR OF LENGTH N X N
C              LEX     INTEGER VECTOR (N)
C              MEX     INTEGER VECTOR (N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION B(NMAX,1), CI(1), T(NMAX,1), TINV(NMAX,1), EX1(NMAX,1),
     * TINVB(NMAX,1), ADBLE(1), LEX(1), MEX(1)
C
C
C
      DO 10  J = 1,N
      DO 10  I = 1,N
      K = N * (J - 1) + I
   10 ADBLE(K) = T(I,J)
      CALL MXINV (ADBLE, N, DET, LEX, MEX)
      IF (DET .EQ. 0.0D0)  WRITE (6,95)
      IF (DET .EQ. 0.0D0)  WRITE (2,95)
      DO 20  J = 1,N
      DO 20  I = 1,N
      K = N * (J - 1) + I
   20 TINV(I,J) = ADBLE(K)
      DO 30  J = 1,NC
      DO 30  I = 1,N
      SUM = 0.0D0
      DO 29  K = 1,N
   29 SUM = SUM + TINV(I,K) * B(K,J)
      TINVB(I,J) = SUM
   30 EX1(I,J) = SUM
      DO 60  J = 1,NC
      I = 1
   35 CONTINUE
      IF (I .GT. N)  GO TO 50
      IF (CI(I)  .EQ. 0.) GO TO 40
      Y1 = TINVB(I,J)
      Y2 = TINVB(I+1,J)
      IF (Y1 .NE. 0.0 .AND. Y2 .NE. 0.0)  GO TO 36
      TINVB(I,J) = 0.0
      TINVB(I+1,J) = 0.0
      GO TO 37
   36 CONTINUE
      TINVB(I,J) = DSQRT((Y1 * Y1 + Y2 * Y2) / 2.)
      TINVB(I+1,J) = DATAN2(Y2 - Y1, Y2 + Y1) * 57.29578
   37 I = I + 2
      GO TO 35
   40 CONTINUE
      I = I + 1
      GO TO 35
   50 CONTINUE
   60 CONTINUE
      WRITE (6,100)
      CALL MATPRT (TINVB, N, NC, NMAX)
      RETURN
C
C
C     FORMATS
C
C
  100 FORMAT (1X, 'CONTROL EFFECTIVENESS MATRIX' / 1X, 'FOR COMPLEX EIGE
     *NVALUES, MAG. AND ANGLE(DEG.) ARE DISPLAYED')
   95 FORMAT (1X, 'EIGENGECTOR MATRIX IS SINGULAR' )
      END
      SUBROUTINE DANSKY (A, X, Y, Z, N, NMAX)
C
C     ******************************************************************
C
C     SUBROUTINE DANSKY COMPUTES THE COEFFICIENTS OF THE CHARACTERISTIC
C     EQUATION.  DANSKY CALLS SUBROUTINE POLMPY.  DANSKY IS CALLED BY
C     SUBROUTINE BOLLIN.
C
C     INPUTS:
C
C              AS      CHARACTERISTIC EQUATION MATRIX (N,N)
C              N       ACTUAL SIZE OF MATRIX AS
C              NMAX    MAXIMUM SIZE OF N
C
C     OUTPUTS:
C
C              Z       CHARACTERISTIC EQUATION COEFFICIENT VECTOR (N)
C
C     TEMPORARY STORAGE:
C
C              X       VECTOR (N)
C              Y       VECTOR (N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(NMAX,1), X(1), Z(1), Y(1)
C
C
C
      NN = N
   10 NM1 = NN - 1
      IF (NM1 .EQ. 0)  GO TO 125
      DO 120  I = 1,NM1
      NMI = NN - I
      IPVT = NMI
      NMIM1 = NMI - 1
      NMIP1 = NMI + 1
C     FIND MAXIMUM ELEMENT IN PIVOT ROW
      XMAX = A(NMIP1,NMI)
      IF (NMIM1 .GT. 0)  GO TO 15
      IF (XMAX .EQ. 0.)  GO TO 140
      GO TO 50
   15 DO 20  K1 = 1,NMIM1
      K = NMI - K1
      IF (DABS (A(NMIP1,K)) .LE. DABS (XMAX))  GO TO 20
      XMAX = A(NMIP1,K)
      IPVT = K
   20 CONTINUE
      IF (XMAX .EQ. 0.)  GO TO 140
      IF (IPVT .EQ. NMI)  GO TO 50
C     SIMULARITY TRANSFORM SO PIVOT ELEMENT IS THE MAXIMUM
      DO 30  J = 1,NMIP1
      SAVE = A(J,IPVT)
      A(J,IPVT) = A(J,NMI)
   30 A(J,NMI) = SAVE
      DO 40  J = 1,NN
      SAVE = A(IPVT,J)
      A(IPVT,J) = A(NMI,J)
   40 A(NMI,J) = SAVE
C     A UPDATE EQUALS A * M(SUB N-1)
   50 PIVOT = 1. / A(NMIP1,NMI)
      DO 80  K = 1,NN
      IF (K .EQ. NMI)  GO TO 80
      CK =  - A(NMIP1,K) * PIVOT
      DO 70  II = 1,NMI
   70 A(II,K) = A(II,K) + A(II,NMI) * CK
   80 CONTINUE
      DO 85  II = 1,NMI
   85 A(II,NMI) = A(II,NMI) * PIVOT
C     MULT M(SUB N-1) INVERSE TIMES A UPDATED
      DO 110  II = 1,NN
      SUM = 0.
      DO 90  K = 1,NMI
   90 SUM = SUM + A(NMIP1,K) * A(K,II)
      IF (II .LT. NMI)  GO TO 100
      IF (II .EQ. NN)  GO TO 100
      SUM = SUM + A(NMIP1,II+1)
  100 A(NMI,II) = SUM
  110 CONTINUE
  120 CONTINUE
  125 NMIP1 = 1
C     ELEMENTS OF C SET EQUAL TO LAST ELEMENTS IN ROW NMIP1 OF -A
  140 DO 150  J = NMIP1,NN
      NX = J - NMIP1 + 1
  150 X(NX) =  - A(NMIP1,J)
C     MULTIPLY OUT FACTORS OF CHARACTERISTIC EQUATION
      NY = N - NN
      DO 200  J = 1,NY
  200 Y(J) = Z(J)
      CALL POLMPY (X, Y, Z, NX, NY, NYPNX)
C     REDUCE SYSTEM ORDER
      NN = NN - NX
      IF (NN .GT. 0)  GO TO 10
      RETURN
      END
      SUBROUTINE DAVISO (A, B, C, N, NMAX, MC)
C
C     ******************************************************************
C
C     SUBROUTINE DAVISO TRANSFORMS X(DOT)=AX+BU,Y=C(TRANSPOSE)X USING
C     Z=TX SUCH THAT Y IS A STATE VARIABLE OF Z(DOT)=TAT(INVERSE)+TBU.
C     DAVISO DOES NOT CALL ANY SUBROUTINES.  DAVISO IS CALLED BY
C     SUBROUTINE BOLLIN.
C
C     INPUTS:
C
C              A       SYSTEM MATRIX (N,N)
C              B       SYSTEM VECTOR (N)
C              C       SYSTEM VECTOR (N)
C              N       ACTUAL SIZE OF MATRIX A
C              NMAX    MAXIMUM SIZE OF N
C
C     OUTPUTS:
C
C              A       TRANSFORMED MATRIX A (N,N)
C              B       TRANSFORMED VECTOR B (N)
C
C     TEMPORARY STORAGE:
C
C              MC      INTEGER SCALAR
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(NMAX,1), B(1), C(1)
C
C     FIND MAX ELEMENT IN C AS C(MC)
C
      CM = 0.
      MC = 0
      DO 5  J = 1,N
      IF (DABS (C(J)) .LT. CM)  GO TO 5
      CM = DABS(C(J))
      MC = J
    5 CONTINUE
      IF (MC .GT. 0)  GO TO 10
      WRITE (6,7)
      PAUSE
C     PREMULT A BY T CHANGES MC ROW ONLY
   10 DO 17  K = 1,N
      SUM = 0.
      DO 15  J = 1,N
   15 SUM = SUM + (C(J) * A(J,K))
   17 A(MC,K) = SUM
C     POST MULT A BY T INVERSE
C             FOR J NOT = MC: A(K,J)=A(K,J)-A(K,MC)*C(J)/C(MC)
      PIVOT = 1. / C(MC)
      DO 30  J = 1,N
      IF (J .EQ. MC)  GO TO 30
      DO 25  K = 1,N
   25 A(K,J) = A(K,J) - A(K,MC) * C(J) * PIVOT
   30 CONTINUE
C             FOR J = MC:       A(K,MC)=A(K,MC)/C(MC)
      DO 35  K = 1,N
   35 A(K,MC) = A(K,MC) * PIVOT
C     PRE MULT B BY T CHANGES B(MC) ONLY
      SUM = 0.
      DO 37  J = 1,N
   37 SUM = SUM + (C(J) * B(J))
      B(MC) = SUM
      RETURN
C
C
C     FORMAT
C
C
    7 FORMAT (1X, 'ALL ELEMENTS OF C ARE ZERO')
      END
      SUBROUTINE DSCA (A, R, CC, N, MS)
C
C     ******************************************************************
C
C     SUBROUTINE DSCA FORMS R = A + CC * I, FOR EITHER VECTOR OR MATRIX
C     IN VECTOR STORAGE MODE.  DSCA DOES NOT CALL ANY SUBROUTINES.
C     DSCA IS CALLED BY SUBROUTINE LAPNV.
C
C     INPUTS:
C
C              A       INPUT MATRIX (N,N), OR INPUT VECTOR (N)
C              CC      CONSTANT
C              N       ACTUAL SIZE OF SUBSCRIPT(S) OF MATRIX (VECTOR) A
C              MS      DECISION VARIABLE, 2 = MATRIX, 0 OR 1 = VECTOR
C
C     OUTPUTS:
C
C              R       OUTPUT MATRIX (N,N), OR OUTPUT VECTOR (N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1), R(1)
C
C
C
      C = CC
      N1 = N
      M1 = MS + 1
      GO TO (2,2,3),  M1
C
C     A AND R ARE VECTORS
C
    3 CONTINUE
      DO 30  I = 1,N1
      R(I) = A(I) + C
   30 CONTINUE
      RETURN
C
C     A AND R ARE MATRICES
C
    2 CONTINUE
      DO 1  I = 1,N1
      DO 1  J = 1,N1
      M1 = N1 * (J - 1) + I
      R(M1) = A(M1)
      IF (I .NE. J)  GO TO 1
      R(M1) = A(M1) + C
    1 CONTINUE
      RETURN
      END
      SUBROUTINE DSCRT (DT, A, N, NMAX, ITIMES, EADT, INTGRL, C)
C
C     ******************************************************************
C
C     SUBROUTINE DSCRT CALCULATES EXP(A*DT) AND THE INTEGRAL
C     FROM 0 TO DT OF EXP(A*T).  AFTER EACH TERM OF THE SERIES IS
C     MADE ON THE PERCENT CHANGE OCCURRING IN EACH TERM OF INTGRL.
C     WHEN ALL CHANGES ARE LESS THAN .00001%, COMPUTATION IS STOPPED.
C     IF ITIMES=50 BEFORE CONVERGENCE, DSCRT PROMPTS THE USER AS TO
C     WHETHER TO COMPUTE MORE TERMS IN ORDER TO OBTAIN CONVERGENCE.
C     DSCRT DOES NOT CALL ANY SUBROUTINES.  DSCRT IS CALLED BY
C     SUBROUTINE AES600.
C
C     INPUTS:
C
C              DT      TIME STEP
C              A       INPUT MATRIX (N,N)
C              N       ACTUAL SIZE OF MATRIX A
C              NMAX    MAXIMUM SIZE OF N
C
C     OUTPUTS:
C
C              ITIMES  NO. OF TERMS IN SERIES EXPANSION
C              EADT    EXP(A*DT) (N,N)
C              INTGRL  INTEGRAL OF EXP(A*T) FROM T=0 TO T=DT (N,N)
C
C     TEMPORARY STORAGE:
C
C              C       VECTOR (N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 INTGRL
      DIMENSION  A(NMAX,1), EADT(NMAX,1), INTGRL(NMAX,1), C(1)
C
C
C
      ITIMES = 1
      FACTOR = 2
C
C     ACCUMULATE SERIES FOR THE INTEGRAL OF EXP(A*T) IN INTGRL(J,I)
C     EADT(J,I) HOLDS THE 'ITIMES' TERM OF THE SERIES, WHICH IS
C     EQUAL TO ((A*DT) ** ITIMES) / (ITIMES+1)
C
      DO 10  I = 1,N
      DO 10  J = 1,N
      EADT(J,I) = 0.D0
      INTGRL(J,I) = 0.D0
      IF (J.EQ.I)  INTGRL(J,I) = 1.
   10 CONTINUE
      DO 20  I = 1,N
      DO 20  J = 1,N
   20 EADT(J,I) = DT * A(J,I) / FACTOR
   21 DO 30  I = 1,N
      DO 30  J = 1,N
      CTEMP = EADT(J,I)
      IF (INTGRL(J,I) .EQ. 0.D0)  GO TO 30
      IF (DABS(CTEMP / INTGRL(J,I)) .LT. 1.E-8)  CTEMP = 0.D0
   30 INTGRL(J,I) = INTGRL(J,I) + CTEMP
      ITIMES = ITIMES + 1
      FACTOR = DFLOAT(ITIMES + 1)
      DO 60  J = 1,N
      DO 40  I = 1,N
      C(I) = 0.D0
      DO 40  K = 1,N
      DTEMP = (A(I,K)) * (EADT(K,J)) * (DT) / (FACTOR)
      IF (C(I) .EQ. 0.D0)  GO TO 40
      IF (DABS(DTEMP / C(I)) .LT. 1.D-14)  DTEMP = 0.D0
   40 C(I) = C(I) + DTEMP
      DO 50  I = 1,N
   50 EADT(I,J) = C(I)
   60 CONTINUE
C
C     CONVERGENCE CHECK TO SEE IF NEXT TERM IN SERIES WILL CHANGE
C     INTGRL BY MORE THAN 10**-5 PERCENT
C
      ICOUNT = 0
      DO 70  J = 1,N
      DO 70  I = 1,N
      IF (EADT(I,J) .EQ. 0.D0)  GO TO 69
      IF (INTGRL(I,J) .EQ. 0.D0)  GO TO 70
      PCCHAN = EADT(I,J) / INTGRL(I,J)
      IF (DABS(PCCHAN) .GT. 1.E-7)  GO TO 70
   69 ICOUNT = ICOUNT + 1
   70 CONTINUE
C
C     IF ALL ELEMENTS OF INTGRL HAVE STOPPED CHANGING, STOP
C     COMPUTING MORE TERMS
C
      IF (ICOUNT .EQ. (N * N))  GO TO 90
C
C     IF 50 TERMS HAVE BEEN COMPUTED BUT NO CONVERGENCE, ALERT USER
C
      IF (ITIMES .EQ. (50 * (ITIMES / 50)))  GO TO 80
      GO TO 21
   80 PRINT 1000,ITIMES
      PAUSE
      GO TO 21
C
C     COMPLETE CALCULATION OF INTGRL
C
   90 DO 100  J = 1,N
      DO 100  I = 1,N
      CTEMP = EADT(I,J)
      IF (INTGRL(I,J) .EQ. 0.D0)  GO TO 100
      IF (DABS(CTEMP / INTGRL(I,J)) .LT. 1.E-8)  CTEMP = 0.D0
  100 INTGRL(I,J) = DT * (INTGRL(I,J) + CTEMP)
C
C     COMPUTE EADT AS EQUAL TO (I + A*INTGRL)
C
      DO 130  J = 1,N
      DO 130  I = 1,N
      EADT(I,J) = 0.D0
      DO 120  K = 1,N
  120 EADT(I,J) = EADT(I,J) + A(I,K) * INTGRL(K,J)
      IF (I .EQ. J)  EADT(I,J) = EADT(I,J) + 1.
  130 CONTINUE
      RETURN
C
C
C     FORMAT
C
C
 1000 FORMAT (1X, 'CONVERGENCE HAS NOT BEEN OBTAINED IN ', I5, ' ATTEMPT
     *S' / 1X, 'TYPE ''GO'' TO CONTINUE')
      END
      SUBROUTINE EGCK (AAA, X, CPR, CPI, EX1, EX2, PLAM, N, NMAX)
C
C     ******************************************************************
C
C     SUBROUTINE EGCK PERFORMS THE EIGENVALUE AND EIGENVECTOR CHECK.  IT
C     FORMS (AAA * X) AND (X * LAMBDA).  EGCK DOES NOT CALL ANY
C     SUBROUTINE.  EGCK IS CALLED BY SUBROUTINE RICSS.
C
C     INPUTS:
C
C              AAA     ORIGINAL MATRIX FOR WHICH EIGENVALUES
C                      AND EIGENVECTORS WERE FOUND (N,N)
C              X       MODIFIED EIGENVECTOR MATRIX (N,N)
C              CPR     VECTOR OF REAL EIGENVALUES (N)
C              CPI     VECTOR OF IMAGINARY EIGENVALUES (N)
C              N       ACTUAL SIZE OF MATRIX AAA
C              NMAX    MAXIMUM SIZE OF N
C
C     OUTPUTS:
C
C              EX1     AAA * X MATRIX (N,N)
C              EX2     X * LAMBDA MATRIX (N,N)
C
C     TEMPORARY STORAGE:
C
C              PLAM    MATRIX (N,N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION AAA(NMAX,1), X(NMAX,1), CPR(1), CPI(1), EX1(NMAX,1),
     * EX2(NMAX,1), PLAM(NMAX,1)
C
C
C
      DO 80  I = 1,N
      DO 80  J = 1,N
      PLAM(I,J) = 0.
      EX1(I,J) = 0.
   80 EX2(I,J) = 0.
      K = 1
   85 IF (CPI(K) .EQ. 0.)  GO TO 90
      PLAM(K,K) = CPR(K)
      PLAM(K+1,K+1) = CPR(K+1)
      PLAM(K,K+1) = CPI(K+1)
      PLAM(K+1,K) = CPI(K)
      K = K + 2
      GO TO 100
   90 PLAM(K,K) = CPR(K)
      K = K + 1
      GO TO 100
  100 CONTINUE
      IF (K .GT. N)  GO TO 110
      GO TO 85
  110 CONTINUE
      DO 120  J = 1,N
      DO 120  I = 1,N
      SUM = 0.0D0
      DO 115  L = 1,N
  115 SUM = AAA(I,L) * X(L,J) + SUM
  120 EX1(I,J) = SUM
      DO 130  J = 1,N
      DO 130  I = 1,N
      SUM = 0.0D0
      DO 125  L = 1,N
  125 SUM = X(I,L) * PLAM(L,J) + SUM
  130 EX2(I,J) = SUM
      RETURN
      END
      SUBROUTINE EGVCTR (AAA, CPR, CPI, X, N2, TT, EXT, AR, AI, IPERN,
     * IPER, IOP2, N2MAX, ISEL, IHALF)
C
C     ******************************************************************
C
C     SUBROUTINE EGVCTR OBTAINS THE N2 BY N2 MODIFIED EIGENVECTOR MATRIX
C     X OF MATRIX AAA USING THE INVERSE ITERATION ALGORITHM.  (THE
C     EIGENVALUES OF AAA SHOULD HAVE BEEN PREVIOUSLY GENERATED USING
C     SUBROUTINE EIGQR AND STORED IN CPR AND CPI.)  IEND SPECIFIES THE
C     NUMBER OF PASSES THRU THE INVERSE ITERATION ALGORITHM.
C     IF ISEL=0, ALL EIGENVECTORS ARE OBTAINED.
C     IF ISEL>0, ONLY THE ISEL (AND NEXT ONE IF A COMPLEX PAIR) IS
C                OBTAINED.
C     IF ISEL<0, THE ISELTH VECTOR IS PRINTED OUT AFTER EACH ITER.
C     IF IHALF=1, THE FIRST N2/2 VECTORS ARE OBTAINED.
C     IF IHALF .NE. 1, ALL VECTORS ARE OBTAINED.
C     EGVCTR CALLS SUBROUTINES ARRAY, FACTR, MATPRT, AND PRMUTE.  EGVCTR
C     IS CALLED BY SUBROUTINES AES400, AES800, AND RICSS.
C
C     INPUTS:
C
C              AAA     MATRIX FOR WHICH EIGENVECTORS ARE TO BE OBTAINED
C                      (N2,N2)
C              CPR     VECTOR OF REAL PARTS OF EIGENVALUES (N2)
C                            (OF AAA)
C              CPI     VECTOR OF IMAGINARY PARTS OF EIGENVALUES (N2)
C                            (OF AAA)
C              N2      ACTUAL SIZE OF MATRIX AAA
C              IOP2    PRINT OPTION: 0, NO PRINT; 1, PRINT
C              N2MAX   MAXIMUM SIZE OF N2
C              ISEL    SELECTION OPTION
C              IHALF   SELECTION OPTION
C
C     OUTPUTS:
C
C              X       MODIFIED EIGENVECTOR MATRIX OF AAA (N2,N2)
C
C     TEMPORARY STORAGE:
C
C              TT      MATRIX (N2,N2)
C              EXT     MATRIX (N2,N2)
C              AR      VECTOR (N2)
C              AI      VECTOR (N2)
C              IPERN   INTEGER VECTOR (N2)
C              IPER    INTEGER VECTOR (N2)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /PRTOP/ IUNIT
      DIMENSION  AAA(N2MAX,1), CPR(1), CPI(1), X(N2MAX,1), TT(N2MAX,1),
     * EXT(N2MAX,1), AR(1), AI(1), IPER(1), IPERN(1)
C
C
C
    5 CONTINUE
      DO 10  J = 1,N2
      DO 10  I = 1,N2
   10 X(I,J) = 1.0
      IEND = 4
      IF (ISEL .EQ. 0)  GO TO 15
      L = IABS(ISEL)
      GO TO 30
   15 CONTINUE
      L = 1
   20 IF (ISEL .EQ. 0)  GO TO 25
      WRITE (2,600)
      READ (2,610)  ISEL
      IF (ISEL .EQ. 0)  GO TO 5
   25 IF (L .GT. N2/2 .AND. IHALF .EQ. 1)  GO TO 470
C
C
      IF (L .GT. N2)  GO TO 470
   30 CONTINUE
      DO 40  J = 1,N2
      DO 40  I = 1,N2
      EXT(I,J) = AAA(I,J)
      IF (I .NE. J)  GO TO 35
      EXT(I,J) = EXT(I,J) - CPR(L)
      IF (DABS(EXT(I,J)) .LT. 1.0D-15)  EXT(I,J) = 1.0D-15
   35 CONTINUE
   40 CONTINUE
      IF (CPI(L) .NE. 0.0)  GO TO 180
C
C     CALCULATE REAL EIGENVECTOR
C
C     FACTOR LHS MATRIX INTO LOWER AND UPPER TRIANGULAR FACTORS
C
      CALL ARRAY (2, N2, N2, N2MAX, EXT)
      CALL FACTR (EXT, AR, N2, N2, IER)
      CALL ARRAY (1, N2, N2, N2MAX, EXT)
      DO 45  I = 1,N2
   45 IPERN(I) = AR(I)
      IF (IER .NE. 3)  GO TO 50
      WRITE (6,490)
      WRITE (2,490)
   50 CONTINUE
C
C     CHECK FOR ZEROS ON DIAGONAL OF UPPER TRIANGULAR MATRIX
C
      DO 80  I = 1,N2
      IF (EXT(I,I) .NE. 0.0)  GO TO 80
      II = I + 1
      AMAX = DABS(EXT(I,II))
      IF (I .EQ. N2)  AMAX = 1.0
      IF (II .GE. N2)  GO TO 60
      II = I + 2
   60 DO 70  J = II,N2
      IF (DABS(EXT(I,J)) .GT. AMAX)  AMAX = DABS(EXT(I,J))
   70 CONTINUE
      IF (AMAX .EQ. 0.0)  AMAX = 1.0
      EXT(I,I) = .5 * AMAX / (2.0 ** 35)
   80 CONTINUE
      ITER = 0
      GO TO 130
C
C     GO TO BACK SUBSTITUTION PHASE
C
   90 ITER = ITER + 1
      IF (ITER .NE. IEND)  GO TO 100
      IF (ISEL  .GE. 0)  GO TO 95
      GO TO 20
   95 IF (ISEL .NE. 0)  GO TO 450
      L = L + 1
      GO TO 20
  100 CONTINUE
      IF (ISEL .GE. 0)  GO TO 105
      WRITE (2,560)  ITER
      WRITE (2,570)  (X(I,L),  I = 1,N2)
      WRITE (2,590)
      PAUSE
  105 CONTINUE
      CALL PRMUTE (X, IPERN, IPER, N2, L, N2MAX)
C
C     BEGIN FORWARD SUBSTITUTION
C
      DO 120  I = 2,N2
      M = I - 1
      SUM = X(I,L)
      DO 110  J = 1,M
  110 SUM = SUM - EXT(I,J) * X(J,L)
  120 X(I,L) = SUM
      X(N2,L) = X(N2,L) / EXT(N2,N2)
C
C     BEGIN BACKWARD SUBSTITUTION
C
  130 DO 150  I = 2,N2
      J = N2 - I + 1
      M = J + 1
      SUM = X(J,L)
      DO 140  K = M,N2
  140 SUM = SUM - X(K,L) * EXT(J,K)
  150 X(J,L) = SUM / EXT(J,J)
      IZ = 1
      ZMAX = DABS(X(1,L))
      DO 160  I  = 2,N2
      ZINT = DABS(X(I,L))
      IF (ZINT .LE. ZMAX)  GO TO 160
      ZMAX = ZINT
      IZ = I
  160 CONTINUE
      ZMAX = X(IZ,L)
      DO 170  I = 1,N2
      X(I,L) = X(I,L) / ZMAX
  170 IF (DABS(X(I,L)) .LT. 1.0D-10)  X(I,L) = 0.0
      GO TO 90
C
C     CALCULATE COMPLEX EIGENVECTOR
C
C     FORM LHS MATRIX  (BETA**2 + ( A - ALPHA*I )**2 )
C
  180 DO 190  J = 1,N2
      DO 190  I = 1,N2
  190 TT(I,J) = EXT(I,J)
      DO 220  J = 1,N2
      DO 210  I = 1,N2
      SUM = 0.0D0
      DO 200  K = 1,N2
  200 SUM = SUM + TT(I,K) * EXT(K,J)
  210 AR(I) = SUM
      DO 220  M = 1,N2
      EXT(M,J) = AR(M)
      IF (M .EQ. J)  EXT(M,J) = AR(M) + CPI(L) * CPI(L)
  220 CONTINUE
C
C     FACTOR LHS MATRIX INTO LOWER AND UPPER TRIANGULAR FACTORS
C
      CALL ARRAY (2, N2, N2, N2MAX, EXT)
      CALL FACTR (EXT, AR, N2, N2, IER)
      CALL ARRAY (1, N2, N2, N2MAX, EXT)
      DO 230  I = 1,N2
  230 IPERN(I) = AR(I)
      IF (IER .NE. 3)  GO TO 240
      WRITE (6,500)
      WRITE (2,500)
  240 CONTINUE
C
C     CHECK FOR ZEROS ON DIAGONAL OF UPPER TRIANGULAR MATRIX
C
      DO 270  I = 1,N2
      AR(I) = 1.0
      IF (EXT(I,I) .NE. 0.0)  GO TO 270
      II = I + 1
      AMAX = DABS(EXT(I,II))
      IF (I .EQ. N2)  AMAX = 1.0
      IF (II .GE. N2)  GO TO 250
      II = I + 2
  250 DO 260  J = II,N2
      IF (DABS(EXT(I,J)) .GT. AMAX)  AMAX = DABS(EXT(I,J))
  260 CONTINUE
      IF (AMAX .EQ. 0.0)  AMAX = 1.0
      EXT(I,I) = .5 * AMAX / (2.0 ** 35)
  270 CONTINUE
      ITER = 0
      LL = L + 1
C
C     GO TO BACK SUBSTITUTION PHASE
C
      GO TO 360
  275 ITER = ITER + 1
      IF (ITER .NE. IEND)  GO TO 290
      IF (ISEL .GE. 0)  GO TO 280
      GO TO 430
  280 IF (ISEL .NE. 0)  GO TO 450
      GO TO 430
C
C     FORM RHS VECTOR FOR FINDING REAL PART OF EIGENVECTOR PAIR
C
  290 CONTINUE
      IF (ISEL .GE. 0)  GO TO 295
      WRITE (2,560)  ITER
      WRITE (2,570)  (X(I,L),  I = 1,N2)
      WRITE (2,580)
      WRITE (2,570)  (X(I,LL),  I = 1,N2)
      WRITE (2,590)
      PAUSE
  295 CONTINUE
      DO 300  I = 1,N2
      AR(I) = X(I,L)
  300 AI(I) = X(I,LL)
      DO 320  I = 1,N2
      SUM = 0.0D0
      DO 310  J = 1,N2
  310 SUM = SUM + TT(I,J) * AR(J)
  320 X(I,L) = SUM
      CALL PRMUTE (X, IPERN, IPER, N2, L, N2MAX)
      CALL PRMUTE (X, IPERN, IPER, N2, LL, N2MAX)
      DO 330  I = 1,N2
  330 X(I,L) =  - X(I,LL) * DABS(CPI(L)) + X(I,L)
C
C     BEGIN FORWARD SUBSTITUTION
C
      DO 350  I = 2,N2
      M = I - 1
      SUM = X(I,L)
      DO 340  J = 1,M
  340 SUM = SUM - EXT(I,J) * X(J,L)
  350 X(I,L) = SUM
      X(N2,L) = X(N2,L) / EXT(N2,N2)
C
C     BEGIN BACKWARD SUBSTITUTION
C
  360 DO 380  I = 2,N2
      J = N2 - I + 1
      M = J + 1
      SUM = X(J,L)
      DO 370  K = M,N2
  370 SUM = SUM - X(K,L) * EXT(J,K)
  380 X(J,L) = SUM / EXT(J,J)
      DO 400  I = 1,N2
      SUM = AR(I)
      DO 390  K = 1,N2
  390 SUM = SUM - TT(I,K) * X(K,L)
  400 X(I,LL) = SUM / DABS(CPI(L))
C
C     BEGIN NORMALIZATION OF EIGENVECTORS
C
      IZ = 1
      ZMAX = X(1,L) * X(1,L) + X(1,LL) * X(1,LL)
      DO 410  I = 2,N2
      ZINT = X(I,L) * X(I,L) + X(I,LL) * X(I,LL)
      IF (ZINT .LE. ZMAX)  GO TO 410
      ZMAX = ZINT
      IZ = I
  410 CONTINUE
      XRMAX = X(IZ,L)
      XIMAX = X(IZ,LL)
      DO 420  I = 1,N2
      XR = (X(I,L) * XRMAX + X(I,LL) * XIMAX) / ZMAX
      XI = (X(I,LL) * XRMAX - X(I,L) * XIMAX) / ZMAX
      X(I,L) = XR
      X(I,LL) = XI
      IF (DABS(X(I,L)) .LT. 1.0D-10)  X(I,L) = 0.0
      IF (DABS(X(I,LL)) .LT. 1.0D-10)  X(I,LL) = 0.0
  420 CONTINUE
      GO TO 275
C
C     ADD AND SUBTRACT COLUMNS OF X TO FORM MODIFIED EIGENVECTOR MATRIX
C
  430 DO 440  I = 1,N2
      SUM = X(I,L)
      X(I,L) = SUM + X(I,LL)
  440 X(I,LL) = SUM - X(I,LL)
      L = L + 2
      GO TO 20
C
C     END OF COMPLEX EIGENVECTOR CALCULATION
C
  450 CONTINUE
      IF (CPI(L) .EQ. 0.)  GO TO 460
      DO 455  I = 1,N2
      SUM = X(I,L)
      X(I,L) = SUM + X(I,LL)
  455 X(I,LL) = SUM - X(I,LL)
  460 CONTINUE
      WRITE (6,540)
      WRITE (6,550)  CPR(L), CPI(L)
      WRITE (6,620)
      WRITE (6,570)  (X(I,L),  I = 1,N2)
      IF (CPI(L) .EQ. 0.)  GO TO 465
      WRITE (6,630)
      WRITE (6,570)  (X(I,LL),  I = 1,N2)
  465 CONTINUE
      GO TO 20
C
C     PRINT OUT EIGENVECTOR MATRIX
C
  470 IF (IOP2 .EQ. 0)  GO TO 480
      WRITE (6,510)
      IUNIT = 6
      CALL MATPRT (X, N2, N2, N2MAX)
  480 CONTINUE
      RETURN
C
C
C     FORMATS
C
C
  490 FORMAT (1H0, 'FACTR USED FOR REAL EIGENVECTOR IS WRONG')
  500 FORMAT (1H0, 'FACTR USED FOR COMPLEX EIGENVECTOR IS WRONG')
  510 FORMAT (// 20X, 'MODIFIED EIGENVECTOR MATRIX       ')
  540 FORMAT (1X, 'SELECTED EIGENVALUE')
  550 FORMAT (1X, 'REAL PART=', 1PE12.4, 'IMAGINARY PART=',  1PE12.4)
  560 FORMAT (1X, 'REAL PART OF EIGENVECTOR FOR ITER=', I1)
  570 FORMAT (1P10E12.4)
  580 FORMAT (1X, 'IMAGINARY PART')
  590 FORMAT (1X, 'ENTER ''GO'' TO CONTINUE')
  600 FORMAT (1X, ' TO SELECT ANOTHER EIGENVECTOR,ENTER ITS NO.(I2); TO
     *OBTAIN ALL VECTORS ENTER ''0'' ')
  610 FORMAT (I2)
  620 FORMAT (1X, 'MODIFIED EIGENVECTOR')
  630 FORMAT (1X, 'SECOND HALF OF MODIFIED EIGENVECTOR PAIR')
      END
      SUBROUTINE EIGEN (A, EIGR, EIGI, EX1, SSS, S, IA, IB, LEX, MEX,
     * IBL, IC, EX4, N, NMAX)
C
C     ******************************************************************
C
C     SUBROUTINE EIGEN OBTAINS THE EIGENVALUES (EIGR AND EIGI) OF N X N
C     MATRIX A BY FIRST REDUCING (IF A IS REDUCIBLE), THEN SCALING,
C     HESSENBURG TRANSFORMING AND FINALLY APPLYING THE 'QR' ALGORITHM
C     EIGEN CALLS SUBROUTINES SCALEA, CONDI, ARRAY, HSBG, AND EIGQR.
C     EIGEN IS CALLED BY SUBROUTINES AES400 AND AES800.
C
C     INPUTS:
C
C              A       MATRIX TO GET EIGENVALUES FOR (N,N)
C              N       ACTUAL SIZE OF MATRIX A
C              NMAX    MAXIMUM SIZE OF N
C
C     OUTPUTS:
C
C              EIGR    VECTOR OF REAL PARTS OF EIGENVALUES (N)
C              EIGI    VECTOR OF IMAGINARY PARTS OF EIGENVALUES (N)
C              S       MATRIX A IN REDUCED AND SCALED FORM (N,N)
C              LEX     BLOCK-DIAGONALIZING PERMUTATION INTEGER
C                      VECTOR (N)
C              MEX     INTEGER VECTOR OF SIZES OF EACH IRREDUCIBLE
C                      BLOCK (N)
C              EX4     VECTOR OF DIAGONAL ELEMENTS OF DIAGONAL SCALING
C                      MATRIX (N)
C
C     TEMPORARY STORAGE:
C
C              EX1     MATRIX (N,N)
C              SSS     MATRIX (N,N)
C              IA      INTEGER VECTOR (N)
C              IB      INTEGER VECTOR (N)
C              IBL     INTEGER VECTOR (N)
C              IC      INTEGER VECTOR (N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /ERRS/ IER
      DIMENSION A(NMAX,1), EIGR(1), EIGI(1), EX1(NMAX,1), SSS(NMAX,1),
     * S(NMAX,1), IA(1), IB(1), LEX(1), MEX(1), IBL(1), IC(1), EX4(1)
C
C
C
      DO 40  J = 1,N
      DO 40  I = 1,N
   40 S(I,J) = A(I,J)
      CALL SCALEA (S, EX4, N, 0, NMAX)
      IF (IER .EQ. 0)  GO TO 42
      DO 41  J = 1,N
      DO 41  I = 1,N
   41 EX1(I,J) = A(I,J)
      CALL CONDI (EX1, SSS, S, IA, IB, LEX, MEX, IBL, IC, EX4, 0, N,
     * NMAX)
   42 CONTINUE
      DO 45  J = 1,N
      DO 45  I = 1,N
   45 EX1(I,J) = S(I,J)
      CALL ARRAY (2, N, N, NMAX, EX1)
      CALL HSBG (N, EX1, N)
      CALL ARRAY (1, N, N, NMAX, EX1)
      IOP = 1
      WRITE (6,51)
      WRITE (2,51)
      CALL EIGQR (EX1, N, EIGR, EIGI, IOP, NMAX)
      WRITE (6,100)
      WRITE (2,100)
      IFLAG = 0
      DO 50  I = 1,N
      IF (IFLAG .NE. 1)  GO TO 48
      IFLAG = 0
      GO TO 50
   48 CONTINUE
      ZETA = 0.0D0
      FN = 0.0D0
      OMEGAN = DSQRT(EIGR(I) * EIGR(I) + EIGI(I) * EIGI(I))
      IF (EIGI(I) .NE. 0.0D0)  IFLAG = 1
      IF (OMEGAN .EQ. 0.0D0)  GO TO 49
      ZETA =  - EIGR(I) / OMEGAN
      FN = OMEGAN / 6.2832
   49 WRITE (6,120)  FN, ZETA
      WRITE (2,120)  FN,ZETA
   50 CONTINUE
      RETURN
C
C
C     FORMATS
C
C
   51 FORMAT (1H0 / 1X, ' EIGENVALUES ')
  100 FORMAT (1H0 / 10X, 'NAT FREQ (HZ)', 5X, 'ZETA '/)
  120 FORMAT (12X, G11.4, 5X, G11.4)
      END
      SUBROUTINE EIGQR (XR, N2, CR, CI, IOP, N2MAX)
C
C     ******************************************************************
C
C     SUBROUTINE EIGQR COMPUTES THE EIGENVALUES OF MATRIX XR USING THE
C     QR ALGORITHM.  THIS MATRIX MUST BE IN UPPER HESSENBERG FORM.
C     THE MAXIMUM NUMBER OF QR ITERATIONS USED IN FINDING ANY ONE
C     EIGQR DOES NOT CALL ANY SUBROUTINES.  EIGQR IS CALLED BY
C     SUBROUTINES EIGEN, RICSS, AND ZEROES.
C
C     INPUTS:
C
C              XR      MATRIX (IN UPPER HESSENBERG FORM) FOR WHICH
C                      EIGENVALUES ARE TO BE FOUND (N2,N2)
C              N2      ACTUAL SIZE OF MATRIX XR
C              IOP     PRINT OPTION
C                      IOP>0, THE EIGENVALUES ARE WRITTEN ON UNIT 06
C                      IOP=0, NO WRITING TAKES PLACE
C                      IOP<0, THE EIGENVALUES ARE WRITTEN ON UNIT 06 AND
C                      ON UNIT 02 (TERMINAL)
C              N2MAX   MAXIMUM SIZE OF N2
C
C     OUTPUTS:
C
C              CR      VECTOR OF REAL PARTS OF EIGENVALUES (N2)
C              CI      VECTOR OF IMAGINARY PARTS OF EIGENVALUES (N2)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION XR(N2MAX,1), CR(1), CI(1), PSI(2), GR(3)
C
C
C
      ITERMX = 70
      FPZ = 1.0D-15
      N = N2
      DO 10  I = 1,N
      CR(I) = 0.0
   10 CI(I) = 0.0
      IF (IOP)  15,30,20
   15 WRITE (2,800)
   20 WRITE (6,800)
   30 ZERO = 0.0
      JJ = 1
C
C     START OF AN ITERATION
C
   40 XNN = 0.0
      XN2 = 0.0
      AA = 0.0
      B = 0.0
      C = 0.0
      DD = 0.0
      R = 0.0
      SIG = 0.0
      ITER = 0
      IF (N - 2)  50,100,110
C
C     ONLY ONE EIGENVALUE TO GO
C
   50 IF (IOP)  55,70,60
   55 WRITE (2,810)  XR(1,1)
   60 WRITE (6,810)  XR(1,1)
   70 CR(1) = XR(1,1)
      CI(1) = 0.0
C
C     RE-ORDER EIGENVALUES AT END OF COMPUTATION
C
   80 CONTINUE
      NE = N2 / 2
      DO 90  I = 1,NE
      NN = N2 - I + 1
      B = CR(I)
      C = CI(I)
      CR(I) = CR(NN)
      CI(I) = CI(NN)
      CR(NN) = B
   90 CI(NN) = C
      RETURN
C
C     INDICATES ONLY 2 EIGENVALUES LEFT
C
  100 JJ =  - 1
C
C     GENERAL CONDITION(MORE THAN 2 EIGENVALUES LEFT)
C
  110 Y = (XR(N-1,N-1) - XR(N,N)) ** 2
      S = 4.0 * XR(N,N-1) * XR(N-1,N)
      ITER = ITER + 1
      IF (DABS(S) - Y * 1.0D-8)  120,120,160
  120 IF (DABS(XR(N-1,N-1)) - DABS(XR(N,N)))  140,130,130
  130 E = XR(N-1,N-1)
      G = XR(N,N)
      GO TO 150
  140 G = XR(N-1,N-1)
      E = XR(N,N)
  150 F = 0.0
      H = 0.0
      GO TO 230
  160 T = Y + S
      IF (DABS(T) - DMAX1(Y,DABS(S)) * 1.0D-6)  170,170,180
  170 T = 0.0
  180 Y = XR(N-1,N-1) + XR(N,N)
      SQ = DSQRT(DABS(T))
      IF (T)  220,190,190
  190 F = 0.0
      H = 0.0
      IF (Y)  210,200,200
  200 E = (Y - SQ) / 2.0
      G = (Y + SQ) / 2.0
      GO TO 230
  210 G = (Y - SQ) / 2.0
      E = (Y + SQ) / 2.0
      GO TO 230
  220 F = SQ / 2.0
      E = Y / 2.0
      G = E
      H =  - F
  230 IF (JJ)  250,240,240
  240 D = 1.0D-10 * (DABS(G) + F)
      IF (DABS(XR(N-1,N-2)) .GT. D)  GO TO 280
  250 IF (IOP)  255,270,260
  255 WRITE (2,810)  E, F, ITER
      WRITE (2,810)  G, H
  260 WRITE (6,810)  E, F, ITER
      WRITE (6,810)  G, H
  270 CR(N) = E
      CI(N) = F
      CR(N-1) = G
      CI(N-1) = H
C
C     INCREMENT N AT END OF COMPLEX PAIR CALCULATION
C
      N = N - 2
      IF (JJ)  80,40,40
  280 IF (DABS(XR(N,N-1)) .GT. 1.0D-10 * DABS(XR(N,N)))  GO TO 320
  290 IF (IOP)  295,310,300
  295 WRITE (2,810)  XR(N,N), ZERO, ITER
  300 WRITE (6,810)  XR(N,N), ZERO, ITER
  310 CR(N) = XR(N,N)
      CI(N) = 0.0
C
C     INCREMENT N AT END OF REAL EIGENVALUE CALCULATION
C
      N = N - 1
      GO TO 40
  320 VQ = DABS(XR(N,N-1)) - DABS(XR(N-1,N-2))
C
C     FINAL CONVERGENCE CHECKS
C
      IF (ITER .LT. 7)  GO TO 350
      IF (DABS(DABS(XN2/XR(N-1,N-2)) - 1.0) - 1.0D-17)  340,340,330
  330 IF (DABS(DABS(XNN/XR(N,N-1)) - 1.0) - 1.0D-17)  340,340,350
C
C     END OF EIGENVALUE COMPUTATION
C
  340 IF (VQ)  290,250,250
  350 IF (ITER .LT. ITERMX)  GO TO 360
      IF (IOP .LT. 0)  WRITE (2,820)
      WRITE (6,820)
      IF (VQ)  290,250,250
  360 IF (ITER .GT. 5)  GO TO 380
      Z1 = DABS(E - AA) + DABS(F - B) - .5 * (DABS(E) + DABS(F))
      Z2 = DABS(G - C) + DABS(H - DD) - .5 * (DABS(G) + DABS(H))
      IF (Z1)  370,400,400
  370 IF (Z2)  380,390,390
  380 R = E * G - F * H
      SIG = E + G
      GO TO 430
  390 R = E * E
      SIG = E + E
      GO TO 430
  400 IF (Z2)  410,420,420
  410 R = G * G
      SIG = G + G
      GO TO 430
  420 R = 0.0
      SIG = 0.0
  430 XNN = XR(N,N-1)
      XN2 = XR(N-1,N-2)
      N1 = N - 1
      IA = N - 2
      IP = IA
      IF (N - 3)  480,480,440
  440 DO 470  J = 3,N1
      J1 = N - J
      IF (DABS(XR(J1+1,J1)) - D)  480,480,450
  450 DEN = XR(J1+1,J1+1) * (XR(J1+1,J1+1) - SIG) + XR(J1+1,J1+2) *
     * XR(J1+2,J1+1) + R
      IF (DEN)  460,470,460
  460 IF (DABS(XR(J1+1,J1) * XR(J1+2,J1+1)) * (DABS(XR(J1+1,J1+1) +
     * XR(J1+2,J1+2) - SIG) + DABS(XR(J1+3,J1+2))) - DABS(DEN) * D)
     * 490,490,470
  470 IP = J1
  480 IQ = IP
      GO TO 520
  490 IP1 = IP - 1
      IQ = IP1
      IF (IP1 - 1)  520,520,500
  500 DO 510  J = 2,IP1
      J1 = IP - J + 1
      IF (DABS(XR(J1+1,J1)) - D)  520,520,510
  510 IQ = IQ - 1
  520 DO 790  I = IP,N1
      IF (I - IP)  540,530,540
  530 GR(1) = XR(IP,IP) * (XR(IP,IP) - SIG) + XR(IP,IP+1) * XR(IP+1,IP)
     * + R
      GR(2) = XR(IP+1,IP) * (XR(IP,IP) + XR(IP+1,IP+1) - SIG)
      GR(3) = XR(IP+1,IP) * XR(IP+2,IP+1)
      XR(IP+2,IP) = 0.0
      GO TO 570
  540 GR(1) = XR(I,I-1)
      GR(2) = XR(I+1,I-1)
      IF (I - IA)  550,550,560
  550 GR(3) = XR(I+2,I-1)
      GO TO 570
  560 GR(3) = 0.0
  570 CONTINUE
      IF (DABS(GR(1)) .LT. FPZ)  GR(1) = 0.0
      IF (DABS(GR(2)) .LT. FPZ)  GR(2) = 0.0
      IF (DABS(GR(3)) .LT. FPZ)  GR(3) = 0.0
      XK = DSIGN(DSQRT(GR(1) ** 2 + GR(2) ** 2 + GR(3) ** 2),GR(1))
      IF (XK)  580,590,580
  580 PSI(1) = GR(2) / (GR(1) + XK)
      PSI(2) = GR(3) / (GR(1) + XK)
      IF (DABS(PSI(1)) .LT. FPZ)  PSI(1) = 0.0
      IF (DABS(PSI(2)) .LT. FPZ)  PSI(2) = 0.0
      AL = GR(1) / XK + 1.0
      GO TO 600
  590 AL = 2.0
      PSI(1) = 0.0
      PSI(2) = 0.0
  600 IF (I - IQ)  610,640,610
  610 IF (I - IP)  630,620,630
  620 XR(I,I-1) =  - XR(I,I-1)
      GO TO 640
  630 XR(I,I-1) =  - XK
  640 DO 690  J = I,N
      IF (I - N1)  650,660,660
  650 DR = PSI(2) * XR(I+2,J)
      GO TO 670
  660 DR = 0.0
  670 ER = AL * (XR(I,J) + PSI(1) * XR(I+1,J) + DR)
      IF (DABS(ER) .LT. FPZ)  ER = 0.0
      XR(I,J) = XR(I,J) - ER
      XR(I+1,J) = XR(I+1,J) - PSI(1) * ER
      IF (I - N1)  680,690,690
  680 XR(I+2,J) = XR(I+2,J) - PSI(2) * ER
  690 CONTINUE
      IF (I - N1)  700,710,710
  700 L = I + 2
      GO TO 720
  710 L = N
  720 DO 770  J = IQ,L
      IF (I - N1)  730,740,740
  730 DR = PSI(2) * XR(J,I+2)
      GO TO 750
  740 DR = 0.0
  750 ER = AL * (XR(J,I) + PSI(1) * XR(J,I+1) + DR)
      IF (DABS(ER) .LT. FPZ)  ER = 0.0
      XR(J,I) = XR(J,I) - ER
      XR(J,I+1) = XR(J,I+1) - PSI(1) * ER
      IF (I - N1)  760,770,770
  760 XR(J,I+2) = XR(J,I+2) - PSI(2) * ER
  770 CONTINUE
      IF (I - IA)  780,790,790
  780 ER = AL * PSI(2) * XR(I+3,I+2)
      IF (DABS(ER) .LT. FPZ)  ER = 0.0
      XR(I+3,I) =  - ER
      XR(I+3,I+1) =  - PSI(1) * ER
      XR(I+3,I+2) = XR(I+3,I+2) - PSI(2) * ER
  790 CONTINUE
      AA = E
      B = F
      C = G
      DD = H
      GO TO 110
C
C
C     FORMATS
C
C
  800 FORMAT (1H0, 'REAL PART', 6X, 'IMAGINARY PART', 5X, 'ITER' //)
  810 FORMAT (1X, G15.8, 3X, G15.8, 2X, I3)
  820 FORMAT (1X, '*****THE FOLLOWING ANSWER(S) DID NOT CONVERGE*****')
      END
      SUBROUTINE ESTMAT (AA, HH, QQ, RRINV, KE, PP, CR, CI, X, TS, XR,
     * TT, AAA, EXT, AR, AI, IPER, IPERN, ADBLE, N, NM, N2, IOP1, IOP2,
     * NMAX, NMMAX, N2MAX)
C
C     ******************************************************************
C
C     SUBROUTINE ESTMAT SOLVES THE OPTIMAL LINEAR STATE ESTIMATION
C     PROBLEM.  IT SETS UP AN N2 BY N2 MATRIX AAA, USING MATRICES AA,
C     HH, QQ, AND RRINV.  ESTMAT OBTAINS THE KALMAN FILTER ERROR
C     COVARIANCE, PP, AND THEN COMPUTES THE KALMAN FILTER GAINS, KE.
C     ESTMAT CALLS SUBROUTINES MATPRT AND RICSS.  ESTMAT IS CALLED BY
C     SUBROUTINE AES800.
C
C     INPUTS:
C
C              AA      SYSTEM MATRIX (N,N)
C              HH      MEASUREMENT MATRIX (NM,N)
C              QQ      POWER SPECTRAL DENSITY MATRIX (N,N)
C                      (OF PLANT DISTURBANCE)
C              RRINV   INVERSE OF POWER SPECTRAL DENSITY MATRIX (NM,NM)
C                      (OF MEASUREMENT NOISE)
C              IOP1    SCALING PRINT OPTION: 0, NO PRINT; 1, PRINT
C              IOP2    EIGENVECTOR PRINT OPTION: 0, NO PRINT; 1, PRINT
C              N       NUMBER OF STATE VARIABLES
C              NM      NUMBER OF MEASUREMENTS
C              N2      DIMENSION OF HAMILTONIAN MATRIX, 2 X N
C              NMAX    MAXIMUM SIZE OF N
C              NMMAX   MAXIMUM SIZE OF NM
C              N2MAX   MAXIMUM SIZE OF N2
C
C     OUTPUTS:
C
C              KE      KALMAN FILTER GAIN MATRIX (N,NM)
C              PP      KALMAN FILTER ERROR COVARIANCE MATRIX (N,N)
C              CR      VECTOR OF REAL PARTS OF EIGENVALUES (N2)
C                            (OF AAA)
C              CI      VECTOR OF IMAGINARY PARTS OF EIGENVALUES (N2)
C                            (OF AAA)
C              X       MODIFIED EIGENVECTOR MATRIX OF AAA (N2,N2)
C              TS      SCALING TRANSFORMATION VECTOR OF AAA (N2)
C              AAA     HAMILTONIAN MATRIX FOR KALMAN FILTER RICCATI
C                      EQUATION (N2,N2)
C
C     TEMPORARY STORAGE:
C
C              XR      MATRIX (N2,N2)
C              TT      MATRIX (N2,N2)
C              EXT     MATRIX (N2,N2)
C              AR      VECTOR (N2)
C              AI      VECTOR (N2)
C              IPER    INTEGER VECTOR (N2)
C              IPERN   INTEGER VECTOR (N2)
C              ADBLE   VECTOR (N X N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 KE
      COMMON /PRTOP/ IUNIT
      DIMENSION  AA(NMAX,1), HH(NMMAX,1), QQ(NMAX,1), RRINV(NMMAX,1),
     * KE(NMAX,1), PP(NMAX,1), CR(1), CI(1), X(N2MAX,1), TS(1),
     * XR(N2MAX,1), TT(N2MAX,1), AAA(N2MAX,1), EXT(N2MAX,1), AR(1),
     * AI(1), IPER(1), IPERN(1), ADBLE(1)
C
C
C
      WRITE (6,130)
C
C     FORM AAA MATRIX
C
      DO 50  I = 1,N2
      II = I - N
      DO 50  J = 1,N2
      JJ = J - N
      IF (J .GT. N)  GO TO 20
      IF (I .GT. N)  GO TO 10
      AAA(I,J) = - AA(J,I)
      GO TO 50
   10 AAA(I,J) = QQ(II,J)
      GO TO 50
   20 IF (I .GT. N)  GO TO 40
      SUM = 0.0D0
      DO 30  K = 1,NM
      DO 30  L = 1,NM
   30 SUM = SUM + HH(K,I) * RRINV(K,L) * HH(L,JJ)
      AAA(I,J) = SUM
      GO TO 50
   40 AAA(I,J) = AA(II,JJ)
   50 CONTINUE
C
C     OBTAIN SOLUTION TO ESTIMATION RICCATI EQ. AND STORE IN PP
C
      CALL RICSS (AAA, X, PP, CR, CI, TS, XR, EXT, TT, IPER, IPERN, AR,
     * AI, ADBLE, IOP1, IOP2, N, N2, NMAX, N2MAX)
      WRITE (6,160)
      IUNIT = 6
      CALL MATPRT (PP, N, N, NMAX)
C
C     COMPUTE ESTIMATOR GAIN MATRIX KE
C
      DO 100  I = 1,N
      DO 100  J = 1,NM
      SUM = 0.0D0
      DO 90  K = 1,N
      DO 90  L = 1,NM
   90 SUM = SUM + PP(I,K) * HH(L,K) * RRINV(L,J)
  100 KE(I,J) = SUM
      WRITE (6,190)
      IUNIT = 6
      CALL MATPRT (KE, N, NM, NMAX)
      RETURN
C
C
C     FORMATS
C
C
  130 FORMAT (1H0 / 1X, '***********************************************
     *********************' / 15X, 'RESULTS OF KALMAN FILTER DESIGN PROB
     *LEM' / 1X, '******************************************************
     **************' ///)
  160 FORMAT (// 1X, 'PP, THE ESTIMATION ERROR COVARIANCE MATRIX')
  190 FORMAT (// 1X, 'KE, THE KALMAN FILTER GAIN MATRIX')
      END
      SUBROUTINE FACTR (A, PER, N, IA, IER)
C
C     ******************************************************************
C
C     SUBROUTINE FACTR FORMS THE LOWER AND UPPER TRIANGULAR MATRICES OF
C     INPUT MATRIX A, SUCH THAT UPPER * LOWER = A.
C     FACTR DOES NOT CALL ANY SUBROUTINES.  FACTR IS CALLED BY
C     SUBROUTINE EGVCTR.
C
C     INPUTS:
C
C              A       INPUT MATRIX (N,N)
C              N       ACTUAL SIZE OF MATRIX A
C              IA      SAME AS N
C
C     OUTPUTS:
C
C              A       INPUT MATRIX IN UPPER AND LOWER TRIANGULAR
C                      FORM (N,N)
C              PER     TRANSPOSITION VECTOR FOR MATRIX A (N)
C              IER     ERROR OPTION,
C                      IF IER .NE. 0, FACTR IS WRONG
C                      IF IER .EQ. 0, FACTR HAS WORKED CORRECTLY
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1), PER(1)
C
C
C
      ABS(X) = DABS(X)
      DO 20  I = 1,N
      X = 0.0D0
      IJ = I
      DO 10  J = 1,N
      IF (ABS(A(IJ)) - X)  10,10,5
    5 X = ABS(A(IJ))
   10 IJ = IJ + IA
      IF (X)  110,110,20
   20 PER(I) = 1. / X
      I0 = 0
      DO 100  I = 1,N
      IM1 = I - 1
      IP1 = I + 1
      IPIVOT = I
      X = 0.0D0
      DO 50  K = I,N
      KI = I0 + K
      DP = A(KI)
      IF (I - 1)  110,40,25
   25 KJ = K
      DO 30  J = 1,IM1
      IJ = I0 + J
      DP = DP - 1.D0 * A(KJ) * A(IJ)
   30 KJ = KJ + IA
      A(KI) = DP
   40 IF (X - DABS(DP) * PER(K))  45,50,50
   45 IPIVOT = K
      X = DABS(DP) * PER(K)
   50 CONTINUE
      IF (X)  110,110,55
   55 IF (IPIVOT - I)  110,70,57
   57 KI = IPIVOT
      IJ = I
      DO 60  J = 1,N
      X = A(IJ)
      A(IJ) = A(KI)
      A(KI) = X
      KI = KI + IA
   60 IJ = IJ + IA
      PER(IPIVOT) = PER(I)
   70 PER(I) = IPIVOT
      IF (I - N)  72,100,100
   72 IJ = I0 + I
      X = A(IJ)
      K0 = I0 + IA
      DO 90  K = IP1,N
      KI = I0 + K
      A(KI) = A(KI) / X
      IF (I - 1)  110,90,75
   75 IJ = I
      KI = K0 + I
      DP = A(KI)
      DO 80  J = 1,IM1
      KJ = K0 + J
      DP = DP - 1.D0 * A(IJ) * A(KJ)
   80 IJ = IJ + IA
      A(KI) = DP
   90 K0 = K0 + IA
  100 I0 = I0 + IA
      IER = 0
      RETURN
  110 IER = 3
      RETURN
      END
      SUBROUTINE FRPOLY (Z1, Z2, DD, HZ, G, AMP, PHA, N)
C
C     ******************************************************************
C
C     SUBROUTINE FRPOLY EVALUATES TRANSFER FUNCTION Z2(S) / Z1(S) FOR
C     S = 6.28 * HZ * J.  FRPOLY DOES NOT CALL ANY SUBROUTINES.  FRPOLY
C     IS CALLED BY SUBROUTINE FRQP.
C
C     INPUTS:
C
C              Z1      DENOMINATOR COEFFICIENT VECTOR
C              Z2      NUMERATOR COEFFICIENT VECTOR
C              DD      DOUT OR 0.0
C              HZ      FREQUENCY
C              N       SIZE OF COEFFICIENT VECTORS
C
C     OUTPUTS:
C
C              G       COMPLEX TRANSFER FUNCTION
C              AMP     AMPLITUDE
C              PHA     PHASE
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-F,H,O-R,T-Z)
      DIMENSION Z1(1), Z2(1)
      REAL*8 GT, SUM1R, SUM1I, SUM2R, SUM2I
      REAL*4 GAMP, GPHA
      COMPLEX G, SUM1, SUM2
C
C
C
      NM1 = N - 1
      SUM1R = Z1(N)
      SUM1I = 0.
      SUM2R = Z2(N)
      SUM2I = 0.
      GT = 1.
      WJ = HZ * 6.2831853
      KK = 2
      IF (NM1 .EQ. 0)  GO TO 40
      DO 35  K = 1,NM1
      NMK = N - K
      GT = GT * WJ
      ZZ1 = Z1(NMK) * GT
      ZZ2 = Z2(NMK) * GT
      GO TO (5,10,3,8),  KK
    3 ZZ1 =  - ZZ1
      ZZ2 =  - ZZ2
    5 SUM1R = SUM1R + ZZ1
      SUM2R = SUM2R + ZZ2
      GO TO 30
    8 ZZ1 =  - ZZ1
      ZZ2 =  - ZZ2
   10 SUM1I = SUM1I + ZZ1
      SUM2I = SUM2I + ZZ2
   30 KK = KK + 1
      IF (KK .GT. 4)  KK = 1
   35 CONTINUE
C     ADD ON S**N TO DEN SUM1
   40 SUM1 = CMPLX(SNGL(SUM1R),SNGL(SUM1I)) + GT * WJ * (CMPLX(0.,1.))
     * ** (KK - 1)
      SUM2 = CMPLX(SNGL(SUM2R),SNGL(SUM2I)) + DD * GT * WJ *
     * (CMPLX(0.,1.)) ** (KK - 1)
      G = SUM2 / SUM1
      GAMP = CABS(G)
      GPHA = ATAN2(AIMAG(G),REAL(G)) * 57.29578
      AMP = DBLE(GAMP)
      PHA = DBLE(GPHA)
      RETURN
      END
      SUBROUTINE FRQP (Z1, Z2, DD, N, FI, DELF, IF, FREQ, AMP, PHASE,
     * ISPACE, TSFTR)
C
C     ******************************************************************
C
C     SUBROUTINE FRQP GENERATES FREQUENCY RESPONSE AMP. AND PHASE, GIVEN
C     TRANSFER FUNCTION NUMERATOR AND DENOMINATOR POLYNOMIAL
C     COEFFICIENTS (GENERATED BY SUBROUTINE BOLLIN).
C     FRQP CALLS SUBROUTINE FRPOLY, WHICH COMPUTES AMPLITUDE AND PHASE.
C     FRQP IS CALLED BY SUBROUTINE FRSPNS.
C
C     INPUTS:
C
C              Z1      DENOMINATOR POLYNOMIAL COEFFICIENT VECTOR
C              Z2      NUMERATOR POLYNOMIAL COEFFICIENT VECTOR
C              DD      DOUT OR 0.0
C              N       SIZE OF COEFFICIENT VECTORS
C              TSFTR   TIME SCALE FACTOR
C              FI      INITIAL FREQUENCY
C              DELF    SPACING BETWEEN FREQUENCY POINTS
C              IF      NUMBER OF DESIRED POINTS TO BE GENERATED
C              ISPACE  CONTROLS FREQUENCY OF PRINTOUT FOR FREQ,
C                      AMP AND PHASE
C
C     OUTPUTS:
C
C              FREQ    FREQUENCY VECTOR
C              AMP     AMPLITUDE VECTOR
C              PHASE   PHASE VECTOR
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-F,H,O-Z)
      DIMENSION FREQ(1), AMP(1), PHASE(1), Z1(1), Z2(1)
      COMPLEX G
C
C
C
      WRITE (6,15)
      DO 20  JK = 1,IF
      FREQ(JK) = (FI + DELF * FLOAT(JK - 1)) * TSFTR
      CALL FRPOLY (Z1, Z2, DD, FREQ(JK), G, AMP(JK), PHASE(JK), N)
      FREQ(JK) = FREQ(JK) / TSFTR
      JKMISP = MOD(JK,ISPACE)
      IF (JKMISP)  10,10,20
   10 WRITE (6,25)  FREQ(JK), AMP(JK), PHASE(JK), G
   20 CONTINUE
      RETURN
C
C
C     FORMATS
C
C
   15 FORMAT (1H0 / 12X, 'FREQ.(HZ)', 16X, 'AMP.', 4X, 'PHASE ANGLE(DEG)
     *', 11X, 'REAL PART', 6X, 'IMAGINARY PART' /)
   25 FORMAT (1X, 5G20.6)
      END
      SUBROUTINE FRSPNS (A, B, C, DD, IOUT, JIN, N, TSFTR, DXM1, DXV1,
     * DXV2, DXV3, EXM1, EXV1, EXV2, NMAX, NOMAX, DDCOF, DNCOF, FI,
     * DELF, IF, FREQ, AMP, PHASE, ISPACE, IPRNT)
C
C     ******************************************************************
C
C     SUBROUTINE FRSPNS COMPUTES THE FREQUENCY RESPONSE OF THE IOUT
C     OUTPUT TO THE JIN INPUT OF THE SYSTEM  XDOT = A*X + B*U ; Y = C*X
C     FRSPNS CALLS SUBROUTINES BOLLIN AND FRQP.  FRSPNS IS CALLED BY
C     SUBROUTINE AES500.
C
C     INPUTS:
C
C              A       SYSTEM MATRIX (N,N)
C              B       SYSTEM MATRIX (N,NC)
C              C       SYSTEM MATRIX (NO,N)
C              DD      DOUT OR 0.0
C              IOUT    INDEX OF OUTPUT
C              JIN     INDEX OF INPUT
C              N       ACTUAL SIZE OF MATRIX A
C              TSFTR   TIME SCALE FACTOR
C              NMAX    MAXIMUM SIZE OF N
C              NOMAX   MAXIMUM SIZE OF NO
C              FI      INITIAL FREQUENCY
C              DELF    SPACING BETWEEN FREQUENCY POINTS
C              IF      NUMBER OF DESIRED POINTS TO BE GENERATED
C              ISPACE  CONTROLS FREQUENCY OF PRINTOUT FOR FREQ,
C                      AMP AND PHASE
C              IPRNT   PRINT OPTION, 0 IF STANDARD, 1 IF EXTENDED
C
C     OUTPUTS:
C
C              DXV3    NUMERATOR COEFFICIENTS (N)
C              EXM1    A * TSFTR (N,N)
C              EXV1    JINTH ROW OF B * TSFTR (N)
C              EXV2    IOUTTH COLUMN OF C (N)
C              DDCOF   DENOMINATOR COEFFICIENTS (N)
C              DNCOF   NUMERATOR COEFFICIENTS (N)
C              FREQ    FREQUENCY VECTOR (500)
C              AMP     AMPLITUDE VECTOR (500)
C              PHASE   PHASE VECTOR (500)
C
C     TEMPORARY STORAGE:
C
C              DXM1    MATRIX (N,N)
C              DXV1    VECTOR (N)
C              DXV2    VECTOR (N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION A(NMAX,1), B(NMAX,1), C(NOMAX,1), EXM1(NMAX,1), EXV1(1),
     * EXV2(1), DDCOF(1), DNCOF(1), FREQ(1), AMP(1), PHASE(1), DXV1(1),
     * DXV2(1), DXV3(1), DXM1(NMAX,1)
C
C
C
      DDD = 1.0
      DO 10  J = 1,N
      EXV1(J) = B(J,JIN) * TSFTR
      EXV2(J) = C(IOUT,J)
      DO 10  I = 1,N
   10 EXM1(I,J) = A(I,J) * TSFTR
      CALL BOLLIN (EXM1, DXM1, EXV1, EXV2, DXV1, DXV2, DDCOF, DNCOF,
     * DXV3, N, NMAX)
      IF (DD .EQ. 0.0D0)  GO TO 9
      DO 8  I = 1,N
    8 DNCOF(I) = DNCOF(I) + DD * DDCOF(I)
    9 IF (IPRNT)  12,12,11
   11 WRITE (2,13)  DD, N, DDD, N
      WRITE (6,13)  DD, N, DDD, N
      DO 7  I = 1,N
      J = N - I
      WRITE (2,14)  DNCOF(I), J, DDCOF(I), J
      WRITE (6,14)  DNCOF(I), J, DDCOF(I), J
    7 CONTINUE
   12 CONTINUE
      CALL FRQP (DDCOF, DNCOF, DD, N, FI, DELF, IF, FREQ, AMP, PHASE,
     * ISPACE, TSFTR)
      RETURN
C
C
C     FORMATS
C
C
   13 FORMAT (1X, 'NUMERATOR COEFFICIENTS', 10X, 'DENOMINATOR COEFFICIEN
     *TS' / 1X, G12.5, '*S**', I3, 10X, G12.5, '*S**', I3)
   14 FORMAT (1X, G12.5, '*S**', I3, 10X, G12.5, '*S**', I3)
      END
      SUBROUTINE GAIN (AA, BB, CC, DD, II, JJ, N, NZ, GAYN, EX1, EX4,  N
     *MAX, NMMAX)
C
C     ******************************************************************
C
C     SUBROUTINE GAIN IS A COMPANION TO SUBROUTINE ZEROES.  GAIN
C     COMPUTES THE GAIN OF THE TRANSFER FUNCTION RELATING INPUT JJ AND
C     OUTPUT II OF THE FOLLOWING NTH ORDER SYSTEM.
C     (IN STATE VARIABLE FORM):
C          XDOT = AA * X + BB * U
C          Y = CC * X + DD * U
C     GAIN DOES NOT CALL ANY SUBROUTINES.  GAIN IS CALLED BY SUBROUTINE
C     AES700.
C
C     INPUTS:
C
C              AA      SYSTEM MATRIX (N,N)
C              BB      CONTROL INPUT MATRIX (N,NUMBER OF POSSIBLE
C                      INPUTS)
C              CC      OUTPUT MATRIX (NUMBER OF POSSIBLE OUTPUTS,N)
C              DD      SCALAR RELATING U(JJ) TO Y(II)
C              II      INDEX OF OUTPUT Y
C              JJ      INDEX OF INPUT U
C              N       ACTUAL NUMBER OF STATES
C              NZ      NUMBER OF NUMERATOR ZEROES IN TRANSFER FUNCTION
C                      (OBTAINED USING SUBROUTINE ZEROES)
C              NMAX    MAXIMUM SIZE OF N
C              NMMAX   MAXIMUM NUMBER OF OUTPUTS
C
C     OUTPUTS:
C
C              GAYN    TRANSFER FUNCTION GAIN
C
C     TEMPORARY STORAGE:
C
C              EX1     MATRIX (N,N)
C              EX4     VECTOR (N)
C
C     ******************************************************************
C
      IMPLICIT  REAL*8 (A-H,O-Z)
      DIMENSION  AA(NMAX,1), BB(NMAX,1), CC(NMMAX,1), EX1(NMAX,1),
     * EX4(1)
C
C
C
      GAYN = 0.0D0
      IF (DD .EQ. 0.0D0)  GO TO 5
      GAYN = DD
      RETURN
    5 DO 10  J = 1,N
      DO 10  I = 1,N
   10 EX1(I,J) = AA(I,J)
      NEX = N - NZ - 1
      IF ((NEX) .GE. 0)  GO TO 15
      WRITE (2,100)
      WRITE (6,100)
   15 IF ((NEX) .GT. 0)  GO TO 25
      DO 20  I = 1,N
      DO 20  J = 1,N
      EX1(I,J) = 0.0D0
      IF (I .EQ. J)  EX1(I,J) = 1.0D0
   20 CONTINUE
      GO TO 40
   25 IF (NEX .EQ. 1)  GO TO 40
      NEX1 = NEX - 1
      DO 36  NT = 1,NEX1
      DO 36  I = 1,N
      DO 35  J = 1,N
      EX4(J) = 0.0D0
      DO 35  K = 1,N
   35 EX4(J) = EX4(J) + EX1(I,K) * AA(K,J)
      DO 36  L = 1,N
   36 EX1(I,L) = EX4(L)
   40 DO 50  J = 1,N
      SUM = 0.0D0
      DO 45  K = 1,N
   45 SUM = SUM + CC(II,K) * EX1(K,J)
   50 EX4(J) = SUM
      DO 55  K = 1,N
   55 GAYN = GAYN + EX4(K) * BB(K,JJ)
      RETURN
C
C
C     FORMAT
C
C
  100 FORMAT (2X, 'UNABLE TO COMPUTE STEADY STATE GAIN')
      END
      SUBROUTINE HSBG (N, A, IN)
C
C     ******************************************************************
C
C     SUBROUTINE HSBG REDUCES A MATRIX INTO UPPER ALMOST TRIANGULAR
C     FORM.  HSBG DOES NOT CALL ANY SUBROUTINES.  HSBG IS CALLED BY
C     SUBROUTINES EIGEN, RICSS, AND ZEROES.
C
C     INPUTS:
C
C              N       ACTUAL SIZE OF MATRIX A
C              A       INPUT MATRIX (N,N)
C              IN      MAXIMUM SIZE OF MATRIX A IN THE CALLING PROGRAM;
C                      IN = N, WHEN MATRIX A IS IN VECTOR STORAGE MODE.
C
C     OUTPUTS:
C
C              A       OUTPUT MATRIX (N,N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1)
C
C
C
      NN = N
      NIN = NN * IN
      LIN = NIN - IN
C
C     NN IS THE ROW INDEX OF THE ELIMINATION
C
   20 IF (NN - 3)  360,40,40
   40 LIN = LIN - IN
      NN1 = NN - 1
      NN2 = NN1 - 1
C
C     FIND THE PIVOTAL ELEMENT IN THE NNTH ROW
C
      ISUB = LIN + NN
      IPIV = ISUB - IN
      PIV = DABS(A(IPIV))
      IF (NN - 3)  90,90,50
   50 M = IPIV - IN
      DO 80  I = NN,M,IN
      T = DABS(A(I))
      IF (T - PIV)  80,80,60
   60 IPIV = I
      PIV = T
   80 CONTINUE
   90 IF (PIV)  100,320,100
  100 IF (PIV - DABS(A(ISUB)))  180,180,120
C
C     EXCHANGE THE COLUMNS
C
  120 M = IPIV - NN
      DO 140  I = 1,NN
      J = M + I
      T = A(J)
      K = LIN + I
      A(J) = A(K)
  140 A(K) = T
C
C     EXCHANGE THE ROWS
C
      M = NN2 - M / IN
      DO 160  I = NN1,NIN,IN
      T = A(I)
      J = I - M
      A(I) = A(J)
  160 A(J) = T
C
C     TRANSFORMATIONS
C
  180 DO 200  I = NN,LIN,IN
  200 A(I) = A(I) / A(ISUB)
      J =  - IN
      DO 240  I = 1,NN2
      J = J + IN
      NNJ = NN + J
      DO 220  K = 1,NN1
      KJ = K + J
      KL = K + LIN
  220 A(KJ) = A(KJ) - A(NNJ) * A(KL)
  240 CONTINUE
      K =  - IN
      DO 300  I = 1,N
      K = K + IN
      NN1K = NN1 + K
      S = A(NN1K)
      NNIN = NN - IN
      DO 280  J = 1,NN2
      JK = K + J
      NNIN = NNIN + IN
  280 S = S + A(NNIN) * A(JK) * 1.0D0
  300 A(NN1K) = S
C
C     SET THE LOWER PART OF THE MATRIX TO ZERO
C
      DO 310  I = NN,LIN,IN
  310 A(I) = 0.0
  320 NN = NN1
      GO TO 20
  360 RETURN
      END
      SUBROUTINE ICRSP (EX1, C, ICMTX, AMPIN, DT, TIME, TYOUT, XNEW,
     * XOLD, TTIT, TTOP, TYTIT, IEXT, N, NOUT, ITRMX, NMAX, NOUTMX,
     * ITRMXX, IP, NAME, IONPLT)
C
C     ******************************************************************
C
C     SUBROUTINE ICRSP COMPUTES MULTIPLE INITIAL CONDITION RESPONSES OF
C     THE SYSTEM
C           XDOT=A*X      TYOUT=C*X
C     BY SOLVING THE DIFFERENCE EQ.
C           XNEW=EX1*XOLD
C     THIS SUBROUTINE REQUIRES THAT THE STATE TRANSITION MATRIX,
C     EXP(A*DT), BE SUPPLIED AS INPUT MATRIX "EX1".  DESIRED INITIAL
C     CONDITION MAGNITUDES ARE SUPPLIED AS VECTOR 'AMPIN' AND THE
C     DESIRED INITIAL CONDITION-OUTPUT RESPONSE COMBINATIONS ARE
C     SELECTED BY APPROPRIATELY DEFINING ELEMENTS OF THE MATRIX 'ICMTX'.
C     ICRSP CALLS PLOTTING SUBROUTINES ONLY.  ICRSP IS CALLED BY
C     SUBROUTINE AES600.
C
C     INPUTS:
C
C              EX1     STATE TRANSITION, EXP(A*DT), MATRIX (N,N)
C              C       SYSTEM OUTPUT MATRIX (NOUT,N)
C              ICMTX   MATRIX OF ZEROES AND ONES (N,NOUT).
C                      ONES ARE PLACED IN SELECTED MATRIX POSITIONS TO
C                      INDICATE THE INITIAL CONDITION RESPONSES DESIRED.
C                      THE FIRST INDEX IS 'STATE', AND THE SECOND IS
C                      'OUTPUT'.  THUS SUBROUTINE ICRSP MAY CALCULATE AS
C                      MANY AS N*NOUT INITIAL CONDITION RESPONSES.
C              AMPIN   VECTOR OF INPUT INITIAL CONDITION AMPLITUDES (N)
C              DT      TIME STEP
C              TTIT    PLOT TITLE (12)
C              TTOP    PLOT TITLE (12)
C              TYTIT   Y AXIS TITLE (4)
C              N       ACTUAL SIZE OF STATE TRANSITION MATRIX
C              NOUT    ACTUAL NUMBER OF POSSIBLE OUTPUTS
C              ITRMX   NUMBER OF DESIRED TIME RESPONSE POINTS
C              NMAX    MAXIMUM SIZE OF N
C              NOUTMX  MAXIMUM SIZE OF NOUT
C              ITRMXX  MAXIMUM ALLOWABLE VALUE OF ITRMX
C              IP      PLOT ENTITY INDEX (USED BY PLOTSUBS ONLY)
C                      INCREASES BY ONE FOR EACH FRAME
C              NAME    NAME OF PLOT DATASET (9) (USED BY PLOTSUBS ONLY)
C                      (PARTITIONED DATASET THAT HOLDS PLOT ENTITIES)
C              IONPLT  0, IF OFFLINE PLOTS
C                      1, IF ONLINE PLOTS
C
C     OUTPUTS:
C
C              TIME    VECTOR OF TIME POINTS (ITRMXX)
C                      (SINGLE PRECISION)
C              TYOUT   MATRIX OF OUTPUT TRANSIENT RESPONSES FOR ANY
C                      ONE SPECIFIC INITIAL CONTIDION. (ITRMXX,NOUT)
C                      (SINGLE PRECISION)
C              IP      PLOT ENTITY INDEX (USED BY PLOTSUBS ONLY)
C                      INCREASES BY ONE FOR EACH FRAME
C
C     TEMPORARY STORAGE:
C
C              XNEW    VECTOR (N)
C              XOLD    VECTOR (N)
C              IEXT    INTEGER VECTOR (N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-S,U-Z)
      INTEGER*2 INPTS
      LOGICAL*1 IX / .TRUE. /
      LOGICAL*1 IY / .FALSE. /
      COMMON /PLTLEG/ TRUN(4), TDAT(5)
      COMMON /TITLES/ T1(15), T2(15), TNUM(50), T3(15), T4(15), T5(15),
     *T6(15), T7(15), T8(15), T9(15), T10(15), TB1(15), TB2(15), TB3(15)
      DIMENSION  EX1(NMAX,1), C(NOUTMX,1), ICMTX(NMAX,1), AMPIN(1),
     * TIME(1), TYOUT(ITRMXX,1), XNEW(1), XOLD(1), IEXT(1)
      DIMENSION  TTIT(1), TAMPIN(2), TTOP(1), TYTIT(1), TAMPL(3),
     * TNARR(2), TVARSX(7), TVARSY(7), NAME(9), IVARS(7)
      DATA TAMPL / 'AMPL', 'ITUD', 'E = ' /
C
C     CALCULATE RESPONSE FOR L'TH STATE INITIAL CONDITION AND K'TH
C     OUTPUT, AS DETERMINED BY ICMTX
C
      INPTS = ITRMX
      TVARSX(1) = 7.0
      TVARSY(1) = 7.0
      TVARSX(2) = 5.0
      TVARSY(2) = 7.0
      TVARSX(3) = 0.0
      TVARSY(3) = 90.0
      TVARSX(6) = 10.0
      TVARSY(6) = 10.0
      TVARSX(7) = 2.0
      TVARSY(7) = 2.0
      DO 20  I = 1,ITRMX
      AI = I
   20 TIME(I) = (AI - 1.0D0) * DT
      IVARS(1) = 7
      IVARS(2) = ITRMX
      DO 900  L = 1,N
      TTOP(10) = TNUM(L)
      KX = 0
      DO 850  K = 1,NOUT
      IF (ICMTX(L,K) .EQ. 0)  GO TO 850
      KX = KX + 1
      DO 800  I = 1,N
      XOLD(I) = 0.0D0
  800 XNEW(I) = 0.0D0
      XOLD(L) = AMPIN(L)
C
C     MAIN LOOP FOR COMPUTING OUTPUT RESPONSE
C
      DO 840  IK = 1,ITRMX
      IF (IK .NE. 1)  GO TO 822
      TYOUT(IK,KX) = C(K,L) * XOLD(L)
      GO TO 840
  822 CONTINUE
      DO 825  I = 1,N
      XNEW(I) = 0.0D0
      DO 825  KK = 1,N
  825 XNEW(I) = XNEW(I) + EX1(I,KK) * XOLD(KK)
      SUM = 0.0D0
      DO 835  I = 1,N
      XOLD(I) = XNEW(I)
      SUM = C(K,I) * XNEW(I) + SUM
  835 TYOUT(IK,KX) = SUM
  840 CONTINUE
  850 CONTINUE
      IF (KX .EQ. 0)  RETURN
C
C     WRITE OUT RESULTS FOR THE L'TH INITIAL CONDITION AND ALL DESIRED
C     OUTPUTS
C
      WRITE (6,110)  L, AMPIN(L)
      WRITE (6,120)
      ICOL = 0
      DO 50  J = 1,NOUT
   50 ICOL = ICOL + ICMTX(L,J)
      LX = 1
      LXX = 9
      I = 0
      DO 18  J = 1,NOUT
      IF (ICMTX(L,J) .EQ. 0)  GO TO 18
      I = I + 1
      IEXT(I) = J
   18 CONTINUE
    1 IF (ICOL .LT. LXX)  LXX = ICOL
      WRITE (6,4)
      IF ((LXX - LX) .EQ. 8)  WRITE (6,130)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 7)  WRITE (6,131)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 6)  WRITE (6,132)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 5)  WRITE (6,133)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 4)  WRITE (6,134)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 3)  WRITE (6,135)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 2)  WRITE (6,136)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 1)  WRITE (6,137)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 0)  WRITE (6,138)  (IEXT(I),  I=LX,LXX)
      DO 10  I = 1,ITRMX
      WRITE (6,500)  TIME(I), (TYOUT(I,J),  J=LX,LXX)
   10 CONTINUE
      WRITE (6,4)
      IF (ICOL .EQ. LXX)  GO TO 860
      LX = LX + 9
      LXX = LXX + 9
      GO TO 1
  860 CONTINUE
      DO 870  J = 1,ICOL
      IXX = IEXT(J)
      TYTIT(3) = TNUM(IXX)
      IP = IP + 2
      CALL BEGID(IP)
      IP1 = IP - 1
      CALL BEGID (IP1)
      CALL SCLBAK (IX, INPTS, TIME, TNARR)
      CALL GINTVL (TNARR(1), TNARR(2), 10, 0, TVARSX(4), TVARSX(5))
      CALL SCLBAK (IY, INPTS, TYOUT(1,J), TNARR)
      CALL GINTVL (TNARR(1), TNARR(2), 10, 0, TVARSY(4), TVARSY(5))
      CALL XAXIS (1.0, 1.0, TVARSX)
      CALL YAXIS (1.0, 1.0, TVARSY)
      CALL SCISS (3)
      CALL GPLOT (TIME, TYOUT(1,J), IVARS)
      CALL TITLE (3, 16, 10, TYTIT)
      CALL TITLE (4, 4, 10, 'TIME')
      CALL ENDID(IP1, 3, NAME)
      TAMP = AMPIN(L)
      CALL NUMBER (4, TAMP, 8, 2, TAMPIN)
      CALL CHARS (48, TTIT, 0.0, 1.2, 8.8, 10)
      CALL CHARS (44, TTOP, 0.0, 1.2, 8.6, 10)
      CALL CHARS (12, TAMPL, 0.0, 2.7, 8.4, 10)
      CALL CHARS (8, TAMPIN, 0.0, 4.1, 8.4, 10)
      CALL CHARS (20, TDAT, 0.0, 4.0, 8.2, -10)
      CALL CHARS (16, TRUN, 0.0, 4.0, 8.0, -10)
      CALL ENDID (IP, -1, NAME)
      CALL DISPLA (1)
      IF (IONPLT .EQ. 1)  PAUSE
  870 CONTINUE
  900 CONTINUE
      RETURN
C
C
C     FORMATS
C
C
    4 FORMAT (1H0)
  110 FORMAT (1X, 'INITIAL CONDITION ON STATE NO. ', I3, ' EQUAL TO ',
     * G10.4 //)
  120 FORMAT (25X, 'AMPLITUDES OF RESPONSE VARIABLES')
  130 FORMAT (2X, 'TIME', 5X, 9(1X, 'VARIABLE', 1X, I2))
  131 FORMAT (2X, 'TIME', 5X, 8(1X, 'VARIABLE', 1X, I2))
  132 FORMAT (2X, 'TIME', 5X, 7(1X, 'VARIABLE', 1X, I2))
  133 FORMAT (2X, 'TIME', 5X, 6(1X, 'VARIABLE', 1X, I2))
  134 FORMAT (2X, 'TIME', 5X, 5(1X, 'VARIABLE', 1X, I2))
  135 FORMAT (2X, 'TIME', 5X, 4(1X, 'VARIABLE', 1X, I2))
  136 FORMAT (2X, 'TIME', 5X, 3(1X, 'VARIABLE', 1X, I2))
  137 FORMAT (2X, 'TIME', 5X, 2(1X, 'VARIABLE', 1X, I2))
  138 FORMAT (2X, 'TIME', 5X, 1X, 'VARIABLE', 1X, I2)
  500 FORMAT (1X, G10.4, 9G12.4)
      END
      SUBROUTINE LAPNV (A, X, B, QIN, NIN, WORK)
C
C     ******************************************************************
C
C     SUBROUTINE LAPNV SOLVES THE LYAPUNOV EQUATION,
C     X*A' + A*X+B=0
C     WHERE A' IS A TRANSPOSE,
C     A, B, AND X ARE ALL NXN MATRICES IN VECTOR STORAGE MODE, B IS
C     SYMMETRIC ON INPUT, AND X IS SYMMETRIC ON OUTPUT.
C     STEP 1 CALCULATE X(0) = A'*B*A
C     STEP 2  THE EXACT SOLUTION X IS THE LIMIT OF THE SEQUENCE X(M)
C     WHERE THE M REFERS TO THE M-TH TERM OF THE SEQUENCE.
C     COMPUTE EACH TERM X(M+1) RECURSIVELY, BASED ON X(M) AS FOLLOWS,
C     X(M+1)= X(M) + U(M)*X(M) * U'(M)
C     U(0)= (Q*I-A') **(-1) * (Q*I+A')
C     U(M) = U(0) **(2*M)
C     LAPNV CALLS SUBROUTINES DSCA, MXINV, MXMLT, MXTRA, AND MXADD.
C     LAPNV IS CALLED BY SUBROUTINES COVAR AND LYPCK.
C
C     INPUTS:
C
C              A       LYAPUNOV EQUATION MATRIX (NIN,NIN)
C              B       LYAPUNOV EQUATION MATRIX (NIN,NIN)
C              QIN     CONVERGENCE FACTOR (TYPICALLY .1)
C              NIN     ACTUAL SIZE OF MATRIX A
C              WORK(1) CONVERGENCE CHECK CRITERION (TYPICALLY 1.E-6)
C
C     OUTPUTS:
C
C              X       OUTPUT MATRIX (NIN,NIN)
C
C     TEMPORARY STORAGE:
C
C              WORK     VECTOR (2 X NIN X NIN)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1), B(1), X(1), WORK(1)
      DATA MS/0/
      DATA MAXIT/25/
C
C
C
      ERR = WORK(1)
      N = NIN
      Q = QIN
      NN = N * N
C     CALCULATE Q*I+A AND SAVE IN WORK(N*N+1)TO WORK(2*N*N)
      CALL DSCA (A, WORK(NN+1), Q, N, MS)
C     A= Q*I-A
      CALL DSCA (A, A, -Q, N, MS)
      DO 10  I = 1,NN
   10 A(I) =  - A(I)
      Q2 = 2. * Q
C     GET A INVERSE
      CALL MXINV (A, N, DET, WORK, WORK(N+1))
C
C     FORM A*B AND STORE IN WORK
      CALL MXMLT (A, B, WORK, N, N, N)
C
C     COMPUTE X=2.*Q*A'*B*A
      CALL MXTRA (A, B, N, N)
      CALL MXMLT (WORK, B, X, N, N, N)
      DO 20  I = 1,NN
   20 X(I) = X(I) * Q2
C
C     CALCULATE THE V MATRIX OF THE IEEE PAPER
      CALL MXMLT (A, WORK(NN+1), WORK(1), N, N, N)
C     STORE V IN THE A MATRIX
      DO 21  KK = 1,NN
   21 A(KK) = WORK(KK)
C
C     ITERATIVE PART OF PROGRAM
C     START COMPUTING TERMS OF THE SEQUENCE, TEST THE SEQUENCE FOR
C     CONVERGENCE.
C
      DO 5  NUMIT = 1,MAXIT
C     STORE X IN B
      DO 22  KK = 1,NN
   22 B(KK) = X(KK)
C
C     FORM B*A' AND STORE IN WORK
      CALL MXTRA (A, X, N, N)
      CALL MXMLT (B, X, WORK, N, N, N)
C
C     FORM X= A' *B*A
      CALL MXMLT (A, WORK, X, N, N, N)
C
C     ADD X TO B, THE PREVIOUS TERM OF THE SEQUENCE, TO GET
C     THE NEXT TERM OF THE SEQUENCE
C     X= X+B
      CALL MXADD (X, B, X, N, N)
C     COMPARE THIS ANSWER WITH THE PREVIOUS ITERATION
      SUM = 0.
      DO 6   I = 1,N
      II = N * (I - 1) + I
      IF (X(II)  .EQ. 0.) GO TO 6
      SUM = SUM + DABS((X(II) - B(II)) / X(II))
    6 CONTINUE
      IF (SUM .LT. ERR * DFLOAT(N))  GO TO 290
C
C     THE SEQUENCE HAS NOT CONVERGED
C     SQUARE A AND GO BACK AND COMPUTE ANOTHER TERM IN THE
C     SEQUENCE
      CALL MXMLT (A, A, WORK, N, N, N)
      DO 23  KK = 1,NN
   23 A(KK) = WORK(KK)
    5 CONTINUE
      WRITE (6,60)  MAXIT
  290 RETURN
C
C
C     FORMAT
C
C
   60 FORMAT (10X, '*** NO CONVERGENCE AFTER', I3, ' ITERATIONS ***')
      END
      SUBROUTINE LOGSET (TMIN, TMAX, TNARR, INT)
C
C     ******************************************************************
C
C     SUBROUTINE LOGSET CALCULATES THE DECADES NECESSARY TO INCLUDE THE
C     MINIMUM AND MAXIMUM OF THE DATA TO BE PLOTTED.
C     LOGSET DOES NOT CALL ANY SUBROUTINES.
C
C     INPUTS:
C
C              TNARR   ACTUAL DATA MINIMUM AND MAXIMUM (2)
C                      LOCATION 1 HOLDS THE MINIMUM
C                      LOCATION 2 HOLDS THE MAXIMUM
C
C     OUTPUTS:
C
C              TMIN    MINIMUM DECADE FOR PLOTTING
C              TMAX    MAXIMUM DECADE FOR PLOTTING
C              INT     NUMBER OF INTERVALS FOR LOG AXIS
C
C     ******************************************************************
C
      DIMENSION  TNARR(2)
C
C
C
      IF (TNARR(1) .GT. 0.0 .AND. TNARR(2) .GT. 0.0)  GO TO 10
      WRITE (2,60)  TNARR(1), TNARR(2)
      WRITE (6,60)  TNARR(1), TNARR(2)
      RETURN
   10 IF (TNARR(1) .NE. TNARR(2))  GO TO 20
      TNARR(1) = TNARR(1) / 10.0
      TNARR(2) = TNARR(2) * 10.0
   20 TEXT = TNARR(1)
      A = ALOG10(TEXT)
      IF (A .GE. 0.0)  A = A + .001
      IF (A .LT. 0.0)  A = A - .001
      IA = A
      IF (A .LT. 0.0)  IA = IA - 1
      TMIN = 10.0 ** IA
      TEXT = TMIN
      DO 40  I = 1,20
      TEXT = TEXT * 10.0
      IF (TEXT .GE. TNARR(2))  GO TO 50
   40 CONTINUE
      WRITE (2,90)
      WRITE (6,90)
      RETURN
   50 INT = I
      A = ALOG10(TEXT)
      IF (A .GE. 0.0)  A = A + .001
      IF (A .LT. 0.0)  A = A - .001
      IA = A
      TMAX = 10.0 ** IA
      RETURN
C
C
C     FORMATS
C
C
   60 FORMAT (1X, 'NEG DATA FOR LOG, MIN = ', E20.6, 3X, 'MAX = ',
     * E20.6)
   90 FORMAT (1X, 'BAD DATA, MORE THAN 20 DECADES')
      END
      SUBROUTINE LYPCK (A, Q, XHT, E, R, EX1, WORK, N, NMAX)
C
C     ******************************************************************
C
C     SUBROUTINE LYPCK COMPUTES THE RESIDUAL AND ERROR MATRICES
C     ASSOCIATED WITH THE LYAPUNOV EQ.
C          A*X + X*A**T + Q = 0
C     WHERE
C        SOLUTION--XHT
C        RESIDUAL--R=A*XHT + XHT*A**T + Q
C        ERROR-----E=XHT - X
C          WHERE  A*E + E*A**T - R = 0
C
C     WORK VECTOR 'WORK' MUST BE DIMENSIONED >=2*N**2
C     BEFORE COMPUTING E, R IS SYMMETRIZED.
C     THE TRACES OF XHT, R, & E ARE PRINTED OUT; ALSO THE NORMALIZED
C     ERROR INDEX, TR(E)/TR(XHT), AND THE NORMALIZED DIAGONAL ELEMENTS
C     OF THE ERROR MATRIX ARE PRINTED OUT.
C     LYPCK CALLS SUBROUTINES MATPRT, ARRAY, AND LAPNV.  LYPCK IS CALLED
C     BY SUBROUTINE AES800.
C
C     INPUTS:
C
C              A       LYAPUNOV EQUATION MATRIX (N,N)
C              Q       LYAPUNOV EQUATION MATRIX (N,N)
C              XHT     LYAPUNOV SOLUTION MATRIX (N,N)
C              N       ACTUAL SIZE OF MATRIX A
C              NMAX    MAXIMUM SIZE OF N
C
C     OUTPUTS:
C
C              E       ERROR MATRIX (N,N)
C              R       RESIDUAL MATRIX (N,N)
C
C     TEMPORARY STORAGE:
C
C              EX1     MATRIX (N,N)
C              WORK    VECTOR (2 X N X N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(NMAX,1), Q(NMAX,1), XHT(NMAX,1), R(NMAX,1), E(NMAX,1),
     * WORK(1), EX1(NMAX,1)
C
C
C
      DO 10  J = 1,N
      DO 10  I = 1,N
      R(I,J) = Q(I,J)
      DO 10  K = 1,N
   10 R(I,J) = R(I,J) + A(I,K) * XHT(K,J) + XHT(I,K) * A(J,K)
      WRITE (6,100)
      CALL MATPRT (R, N, N, NMAX)
      TRX = 0.0D0
C
C     SYMMETRIZE R, CALCULATE ITS TRACE, AND SET R = -R
C
      TRR = 0.0D0
      DO 20  I = 1,N
      TRX = TRX + XHT(I,I)
      TRR = TRR + R(I,I)
      R(I,I) =  - R(I,I)
      IP1 = I + 1
      DO 15  K = IP1,N
      R(I,K) = ( - R(I,K) - R(K,I)) / 2.0
   15 R(K,I) = R(I,K)
      DO 20  J = 1,N
   20 EX1(I,J) = A(I,J)
      WRITE (6,110)  TRR
      WRITE (2,110)  TRR
      WORK(1) = 1.0D-6
      QIN = 0.1D0
      CALL ARRAY (2, N, N, NMAX, R)
      CALL ARRAY (2, N, N, NMAX, EX1)
      CALL LAPNV (EX1, E, R, QIN, N, WORK)
      CALL ARRAY (1, N, N, NMAX, E)
      WRITE (6,120)
      CALL MATPRT (E, N, N, NMAX)
      WRITE (6,160)
      WRITE (2,160)
      TRE = 0.0D0
      DO 40  I = 1,N
      WORK(I) = E(I,I) / XHT(I,I)
   40 TRE = TRE + E(I,I)
      WRITE (6,170)  (WORK(I),  I = 1,N)
      WRITE (2,170)  (WORK(I),  I = 1,N)
      WRITE (6,130)  TRE
      WRITE (2,130)  TRE
      WRITE (6,140)  TRX
      WRITE (2,140)  TRX
      RATIO = TRE / TRX
      WRITE (6,150)  RATIO
      WRITE (2,150)  RATIO
      RETURN
C
C
C     FORMATS
C
C
  100 FORMAT (1X, 'THE RESIDUAL MATRIX =')
  110 FORMAT (1X, 'THE TRACE OF THE RESIDUAL=', G12.5)
  120 FORMAT (1X, 'THE ERROR MATRIX=')
  130 FORMAT (1X, 'THE TRACE OF THE ERROR=', G12.5)
  140 FORMAT (1X, 'THE TRACE OF THE COVARIANCE=', G12.5)
  150 FORMAT (1X, 'TR(ERROR)/TR(COV.) =', G12.5)
  160 FORMAT (1X, 'NORMALIZED DIAGONAL ELEMENTS OF THE ERROR MATRIX =')
  170 FORMAT (1X, 10G12.5)
      END
      SUBROUTINE MATCHG
C
C     ******************************************************************
C
C     SUBROUTINE MATCHG IS USED FOR CHANGING MATRICES AND DIMENSIONS
C     USING NAMELIST 'MATDAT'.  THE CHANGES IN MATDAT ARE READ IN FROM
C     THE TERMINAL.  DATA IS TRANSFERRED TO PROGRAM AESOP VIA COMMONS
C     'ABETC' AND 'DIMS'.  MATCHG DOES NOT CALL ANY SUBROUTINES.  MATCHG
C     IS CALLED BY SUBROUTINE AES200.
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 NN
      COMMON /ABETC/  A(50,50), B(50,5), C(50,50), D(50,15), H(5,50),
     * QC(50,50), NN(50,5), PCINV(5,5), QQ(50,50), RRINV(5,5),
     * DOUT(50,5), CSP(5,50)
      COMMON /DIMS/  N, NM, NC, ND, NO, NTOT
      NAMELIST /MATDAT/  A, B, C, D, H, DOUT, CSP, QC, NN, PCINV, QQ,
     * RRINV, N, NM, NC, ND, NO
      DATA YES /1HY/
C
C
C
      WRITE (2,90)
      READ (2,100)  YON
      IF (YON .EQ. YES)  WRITE (2,MATDAT)
   10 WRITE (2,110)
      READ (2,MATDAT)
      WRITE (2,250)
      WRITE (2,MATDAT)
      WRITE (2,120)
      READ (2,100)  YON
      IF (YON .EQ. YES)  GO TO 10
      WRITE (6,250)
      WRITE (6,MATDAT)
      RETURN
C
C
C     FORMATS
C
C
   90 FORMAT (1X, 'DISPLAY MATDAT BEFORE MAKING CHANGES?')
  100 FORMAT (A1)
  110 FORMAT (1X, 'ENTER MATDAT CHANGES AS &MATDAT A(1,1)= , ETC. &END')
  120 FORMAT (1X, 'ARE THERE ANYMORE CHANGES, Y OR N?')
  250 FORMAT (1H0)
      END
      SUBROUTINE MATIN
C
C     ******************************************************************
C
C     SUBROUTINE MATIN IS USED FOR INPUTTING MATRICES AND DIMENSIONS
C     FOR A 'SMALL'  LQR/KALMAN FILTER PROBLEM TESTCASE.  IT
C     ALSO PRINTS OUT THE REFS NAMELIST.  DATA IS PROVIDED FOR A 3RD
C     ORDER TEST CASE HAVING TWO CONTROLS AND TWO SET-POINT OUTPUTS, TWO
C     DISTURBANCES AND ONE NOISY MEASUREMENT.  MATIN CALLS SUBROUTINE
C     MATPRT.  MATIN IS CALLED BY SUBROUTINE AES200.
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 NN, KC, KE, KFF
      COMMON /ABETC/  A(50,50), B(50,5), C(50,50), D(50,15), H(5,50),
     * QC(50,50), NN(50,5), PCINV(5,5), QQ(50,50), RRINV(5,5),
     * DOUT(50,5), CSP(5,50)
      COMMON /COM1/ ADBLE(2500), EX1(50,50), EX2(50,50), EX3(50,50),
     * EX4(50), EXT(100,100), KC(5,50), AMBKC(50,50), ANR(50), ANI(50),
     * EIGR(50), EIGI(50), X(100,100), EIGCLR(50), EIGCLI(50), TS2(100),
     * AR(100), AI(100), XR(100,100), TT(100,100), AAA1(100,100),
     * CR(100), CI(100), S(50,50), SS(50,50), SSS(50,50), FREQ(500),
     * AMP(500), PHASE(500), AMP1(500), PHA1(500), AMP2(500), PHA2(500),
     * AMP3(500), PHA3(500), AMPSTR(1000), PHASTR(1000), SETAP(500),
     * ABKCEH(50,50), KE(50,5), PP(50,50), KFF(5,5), AMPSP(5), AMPSR(5),
     * AMPICX(50), EX13(50,5), EX23(5,50), EX33(5,5), EX5(50,5),
     * EX6(5,50), EX7(5,5), IBL(100), IA(100), IB(100), LEX(100),
     * MEX(100), IC(100), MSROLX(5,50), MSROLY(5,50), MSPY(5,50),
     * MSPYSP(5,5), MSPU(5,5), MICOLX(50,50), MICOLY(50,50),
     * MICCLX(50,50), MICCLY(50,50), MICCLU(50,5)
      COMMON /DIMS/  N, NM, NC, ND, NO, NTOT
      COMMON /DIMS2/  NMAX, NMMAX, NCMAX, NDMAX, NOMAX, NTOTMX
      COMMON /PRTOP/  IUNIT
      COMMON /REFCOM/ TSFTR, DT, FI, DELF, ZERMAX, IF, ISPACE, IOUT,
     * IMEAS, JINC, JIND, ITRMX, NCURV, LINLOG, IP, NAME(9)
      NAMELIST /REFS/ TSFTR, DT, FI, DELF, ZERMAX, AMPSP, AMPSR, AMPICX,
     * IF, ISPACE, IOUT, IMEAS, JINC, JIND, ITRMX, NCURV, LINLOG, MSPY,
     * MSPYSP, MSPU, MSROLY, MSROLX, MICCLY, MICCLX, MICCLU, MICOLY,
     * MICOLX
C
C
C
      N = 3
      NM = 1
      NC = 2
      ND = 2
      NO = 2
      NTOT = N + N
      DO 10  J = 1,N
      DO 2  I = 1,NO
    2 C(I,J) = 0.0D0
      DO 3  I = 1,NM
    3 H(I,J) = 0.0D0
      DO 4  I = 1,NC
      NN(J,I) = 0.0D0
      CSP(I,J) = 0.0D0
    4 B(J,I) = 0.0D0
      DO 5  I = 1,ND
    5 D(J,I) = 0.0D0
      DO 10  I = 1,N
      QC(I,J) = 0.0D0
      QQ(I,J) = 0.0D0
   10 A(I,J) = 0.0D0
      DO 8  I = 1,NM
      DO 8  J = 1,NM
    8 RRINV(I,J) = 0.0D0
      DO 9  I = 1,NC
      DO 9  J = 1,NC
    9 PCINV(I,J) = 0.0D0
      DO 13  J = 1,NC
      DO 13  I = 1,NO
   13 DOUT(I,J) = 0.0D0
      A(1,1) = - .1D0
      A(1,2) = 1.0D0
      A(2,3) = 1.0D0
      A(3,2) =  - 1.0D0
      A(3,3) =  - 2.D-3
      B(2,2) = 1.0D0
      B(3,1) = 1.0D0
      C(1,1) = 1.0D0
      C(2,3) = 1.0D0
      H(1,1) = 1.0D0
      D(2,2) = 1.0D0
      D(3,1) = 1.0D0
      DOUT(2,2) = 1.0D0
      CSP(1,1) = 1.0D0
      CSP(2,3) = 2.0D0
      PCINV(1,1) = 1.0D0
      PCINV(2,2) = .1D0
      QC(1,1) = 20.0D0
      QC(2,2) = 1.D0
      QC(3,3) = 10.0D0
      RRINV(1,1) = 1.0D0
      QQ(2,2) = 2.0D0
      QQ(3,3) = 20.0D0
      NN(1,1) = 1.0D0
      NN(2,2) = 3.0D0
      NN(3,1) = 2.0D0
   15 CONTINUE
      WRITE (IUNIT,500)
      WRITE (IUNIT,3019)
      CALL MATPRT (A, N, N, NMAX)
      WRITE (IUNIT,505)
      CALL MATPRT (B, N, NC, NMAX)
      WRITE (IUNIT,506)
      CALL MATPRT (D, N, ND, NMAX)
      WRITE (IUNIT,511)
      CALL MATPRT (C, NO, N, NOMAX)
      WRITE (IUNIT,512)
      CALL MATPRT (H, NM, N, NMMAX)
      WRITE (IUNIT,524)
      CALL MATPRT (DOUT, NO, NC, NOMAX)
      WRITE (IUNIT,526)
      CALL MATPRT (CSP, NC, N, NCMAX)
      WRITE (IUNIT,514)
      CALL MATPRT (QC, N, N, NMAX)
      WRITE (IUNIT,516)
      CALL MATPRT (NN, N, NC, NMAX)
      WRITE (IUNIT,518)
      CALL MATPRT (PCINV, NC, NC, NCMAX)
      WRITE (IUNIT,520)
      CALL MATPRT (QQ, N, N, NMAX)
      WRITE (IUNIT,522)
      CALL MATPRT (RRINV, NM, NM, NMMAX)
      WRITE (IUNIT,REFS)
      IF (IUNIT .EQ. 6)  RETURN
      IUNIT = 6
      GO TO 15
C
C
C     FORMATS
C
C
  500 FORMAT (1X, '****** INPUT MATRICES ******' / )
  505 FORMAT (1X, 'B=')
  506 FORMAT (1X, 'D=')
  511 FORMAT (1X, 'C=')
  512 FORMAT (1X, 'H=')
  514 FORMAT (1X, 'QC=')
  516 FORMAT (1X, 'NN=')
  518 FORMAT (1X, 'PCINV=')
  520 FORMAT (1X, 'QQ=')
  522 FORMAT (1X, 'RRINV=')
  524 FORMAT (1X, 'DOUT=')
  526 FORMAT (1X, 'CSP=')
 3019 FORMAT (1X, 'A=')
      END
      SUBROUTINE MATPRT (A, N, M, NMAX)
C
C     ******************************************************************
C
C     SUBROUTINE MATPRT PRINTS MATRIX A TEN COLUMNS PER PAGE. THE DEVICE
C     ON WHICH THE PRINTING TAKES PLACE IS CONTROLLED BY 'IUNIT'.
C     IUNIT=2---TERMINAL, IUNIT=6---LINEPRINTER.
C     MATPRT DOES NOT CALL ANY SUBROUTINES.  MATPRT IS CALLED BY
C     SUBROUTINES AES200, AES300, AES400, AES600, AES700, AES800, COVAR,
C     CTBL, EGCK, LYPCK, MATIN, MATRD, MODSHP, OBSBL, RESI, RICCHK,
C     RICSS, AND UNRML.
C
C     INPUTS:
C
C              A       MATRIX TO BE PRINTED (N,M)
C              N       NUMBER OF ROWS IN MATRIX A
C              M       NUMBER OF COLUMNS IN MATRIX A
C              NMAX    MAXIMUM SIZE OF N
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /PRTOP/  IUNIT
      DIMENSION A(NMAX,1)
C
C
C
      LX = 1
      LXX = 10
    1 IF (M .LT. LXX)  LXX = M
      WRITE (IUNIT,4)
      WRITE (IUNIT,5)  (J, J = LX,LXX)
      WRITE (IUNIT,4)
      DO 2  I = 1,N
      WRITE (IUNIT,3)  I, (A(I,J), J = LX,LXX)
    2 CONTINUE
      WRITE (IUNIT,4)
      IF (M .EQ. LXX)  RETURN
      LX = LX + 10
      LXX = LXX + 10
      GO TO 1
C
C
C     FORMATS
C
C
    4 FORMAT (1H0)
    3 FORMAT (1X, I2, 1X, 10G12.4)
    5 FORMAT (4X, 10(I6, 6X))
      END
      SUBROUTINE MATRD
C
C     ******************************************************************
C
C     SUBROUTINE MATRD IS USED FOR INPUTTING MATRICES, DIMENSIONS, AND
C     REFS USING NAMELISTS 'MATDAT' AND 'REFS'.  MATDAT AND REFS ARE
C     READ IN FROM UNIT 33.  DATA IS TRANSFERRED TO PROGRAM AESOP VIA
C     COMMONS 'COM1', 'ABETC', 'DIMS', 'DIMS2', AND 'REFCOM'.
C     MATRD CALLS SUBROUTINE MATPRT.  MATRD IS CALLED BY SUBROUTINE
C     AES200.
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 NN, KC, KE, KFF
      COMMON /ABETC/  A(50,50), B(50,5), C(50,50), D(50,15), H(5,50),
     * QC(50,50), NN(50,5), PCINV(5,5), QQ(50,50), RRINV(5,5),
     * DOUT(50,5), CSP(5,50)
      COMMON /COM1/ ADBLE(2500), EX1(50,50), EX2(50,50), EX3(50,50),
     * EX4(50), EXT(100,100), KC(5,50), AMBKC(50,50), ANR(50), ANI(50),
     * EIGR(50), EIGI(50), X(100,100), EIGCLR(50), EIGCLI(50), TS2(100),
     * AR(100), AI(100), XR(100,100), TT(100,100), AAA1(100,100),
     * CR(100), CI(100), S(50,50), SS(50,50), SSS(50,50), FREQ(500),
     * AMP(500), PHASE(500), AMP1(500), PHA1(500), AMP2(500), PHA2(500),
     * AMP3(500), PHA3(500), AMPSTR(1000), PHASTR(1000), SETAP(500),
     * ABKCEH(50,50), KE(50,5), PP(50,50), KFF(5,5), AMPSP(5), AMPSR(5),
     * AMPICX(50), EX13(50,5), EX23(5,50), EX33(5,5), EX5(50,5),
     * EX6(5,50), EX7(5,5), IBL(100), IA(100), IB(100), LEX(100),
     * MEX(100), IC(100), MSROLX(5,50), MSROLY(5,50), MSPY(5,50),
     * MSPYSP(5,5), MSPU(5,5), MICOLX(50,50), MICOLY(50,50),
     * MICCLX(50,50), MICCLY(50,50), MICCLU(50,5)
      COMMON /DIMS/  N, NM, NC, ND, NO, NTOT
      COMMON /DIMS2/  NMAX, NMMAX, NCMAX, NDMAX, NOMAX, NTOTMX
      COMMON /PRTOP/  IUNIT
      COMMON /REFCOM/ TSFTR, DT, FI, DELF, ZERMAX, IF, ISPACE, IOUT,
     * IMEAS, JINC, JIND, ITRMX, NCURV, LINLOG, IP, NAME(9)
      NAMELIST /MATDAT/  A, B, C, D, H, DOUT, CSP, QC, NN, PCINV, QQ,
     * RRINV, N, NM, NC, ND, NO
      NAMELIST /REFS/ TSFTR, DT, FI, DELF, ZERMAX, AMPSP, AMPSR, AMPICX,
     * IF, ISPACE, IOUT, IMEAS, JINC, JIND, ITRMX, NCURV, LINLOG, MSPY,
     * MSPYSP, MSPU, MSROLY, MSROLX, MICCLY, MICCLX, MICCLU, MICOLY,
     * MICOLX
      DATA YES /1HY/
C
C
C
      DO 10  J = 1,NMAX
      DO 2  I = 1,NOMAX
    2 C(I,J) = 0.0D0
      DO 3  I = 1,NMMAX
    3 H(I,J) = 0.0D0
      DO 4  I = 1,NCMAX
      CSP(I,J) = 0.0D0
      NN(J,I) = 0.0D0
    4 B(J,I) = 0.0D0
      DO 5  I = 1,NDMAX
    5 D(J,I) = 0.0D0
      DO 10  I = 1,NMAX
      QC(I,J) = 0.0D0
      QQ(I,J) = 0.0D0
   10 A(J,I) = 0.0D0
      DO 7  J = 1,NCMAX
      DO 7  I = 1,NOMAX
    7 DOUT(I,J) = 0.0D0
      DO 8  I = 1,NMMAX
      DO 8  J = 1,NMMAX
    8 RRINV(I,J) = 0.0D0
      DO 9  I = 1,NCMAX
      DO 9  J = 1,NCMAX
    9 PCINV(I,J) = 0.0D0
      WRITE (2,100)
      PAUSE
      READ (33,MATDAT)
      READ (33,REFS)
      NTOT = N + N
      IUNIT = 6
      WRITE (2,90)
      READ (2,110)  YON
      IF (YON .EQ. YES)  IUNIT = 2
   15 CONTINUE
      WRITE (IUNIT,500)
      WRITE (IUNIT,3019)
      CALL MATPRT (A, N, N, NMAX)
      WRITE (IUNIT,505)
      CALL MATPRT (B, N, NC, NMAX)
      WRITE (IUNIT,506)
      CALL MATPRT (D, N, ND, NMAX)
      WRITE (IUNIT,511)
      CALL MATPRT (C, NO, N, NOMAX)
      WRITE (IUNIT,512)
      CALL MATPRT (H, NM, N, NMMAX)
      WRITE (IUNIT,524)
      CALL MATPRT (DOUT, NO, NC, NOMAX)
      WRITE (IUNIT,526)
      CALL MATPRT (CSP, NC, N, NCMAX)
      WRITE (IUNIT,514)
      CALL MATPRT (QC, N, N, NMAX)
      WRITE (IUNIT,516)
      CALL MATPRT (NN, N, NC, NMAX)
      WRITE (IUNIT,518)
      CALL MATPRT (PCINV, NC, NC, NCMAX)
      WRITE (IUNIT,520)
      CALL MATPRT (QQ, N, N, NMAX)
      WRITE (IUNIT,522)
      CALL MATPRT (RRINV, NM, NM, NMMAX)
      WRITE (IUNIT,REFS)
      IF (IUNIT .EQ. 6)  RETURN
      IUNIT = 6
      GO TO 15
C
C
C     FORMATS
C
C
   90 FORMAT (1X, 'DISPLAY INPUT MATRICES?')
  100 FORMAT (1X, 'IF NOT ALREADY DONE, DDEF DATASET CONTAINING NAMELIST
     *S' / 1X, '''MATDAT'' AND ''REFS'' TO UNIT 33')
  110 FORMAT (A1)
  500 FORMAT (1X, '****** INPUT MATRICES ******')
  505 FORMAT (1X, 'B=')
  506 FORMAT (1X, 'D=')
  511 FORMAT (1X, 'C=')
  512 FORMAT (1X, 'H=')
  514 FORMAT (1X, 'QC=')
  516 FORMAT (1X, 'NN=')
  518 FORMAT (1X, 'PCINV=')
  520 FORMAT (1X, 'QQ=')
  522 FORMAT (1X, 'RRINV=')
  524 FORMAT (1X, 'DOUT=')
  526 FORMAT (1X, 'CSP=')
 3019 FORMAT (1X, 'A=')
      END
      SUBROUTINE MODSHP (A, B, CI, N, NMAX)
C
C     ******************************************************************
C
C     SUBROUTINE MODSHP CALCULATES MODE SHAPES IN MAGNITUDE AND
C     ANGLE (DEGREE) FORM.  MODSHP CALLS SUBROUTINE MATPRT.  MODSHP IS
C     CALLED BY SUBROUTINES AES400, AES800, AND RICSS.
C
C     INPUTS:
C
C              A       MODIFIED EIGENVECTOR MATRIX (N,N)
C              CI      VECTOR OF IMAGINARY EIGENVALUES (N)
C              N       ACTUAL NUMBER OF EIGENVALUES
C              NMAX    MAXIMUM SIZE OF N
C
C     OUTPUTS:
C
C              B       MODESHAPE IN MAGNITUDE AND ANGLE FORM (N,N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(NMAX,1), B(NMAX,1), CI(1)
C
C
C
      J = 1
   10 CONTINUE
      IF (J .GT. N)  GO TO 50
      IF (CI(J) .EQ. 0.)  GO TO 20
      DO 30  I = 1,N
      XR = (A(I,J) + A(I,J+1)) / 2.
      XI = (A(I,J) - A(I,J+1)) / 2.
      XMAG = DSQRT(XR * XR + XI * XI)
      IF (XR .NE. 0.)  GO TO 15
      PHA = 0.
      GO TO 16
   15 PHA = DATAN2(XI,XR) * 57.29578
   16 CONTINUE
      B(I,J) = XMAG
   30 B(I,J+1) = PHA
      J = J + 2
      GO TO 10
   20 DO 40  I = 1,N
   40 B(I,J) = A(I,J)
      J = J + 1
      GO TO 10
   50 WRITE (6,100)
      CALL MATPRT (B, N, N, NMAX)
      RETURN
C
C
C     FORMAT
C
C
  100 FORMAT (1X, 'THE MATRIX OF MODE SHAPES, IN MAG. AND ANGLE(DEG.) FO
     *RM')
      END
      SUBROUTINE MXADD (A, B, R, N, M)
C
C     ******************************************************************
C
C     SUBROUTINE MXADD ADDS TWO IDENTICALLY SIZED MATRICES TO FORM A
C     RESULTANT MATRIX.  R CAN BE THE SAME AS A OR B IN THE CALLING
C     PROGRAM.  MXADD DOES NOT CALL ANY SUBROUTINES.  MXADD IS CALLED
C     BY SUBROUTINE LAPNV.
C
C     INPUTS:
C
C              A       FIRST INPUT MATRIX (N,M)
C              B       SECOND INPUT MATRIX (N,M)
C              N       NUMBER OF ROWS IN MATRICES A, B, AND R
C              M       NUMBER OF COLUMNS IN MATRICES A, B, AND R
C
C     OUTPUTS:
C
C              R       OUTPUT MATRIX (N,M)
C
C     ******************************************************************
C
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION A(1),B(1),R(1)
C
C     CALCULATE NUMBER OF ELEMENTS IN MATRICES
C
      NM = N * M
C
C     ADD MATRICES
C
      DO 10  I = 1,NM
   10 R(I) = A(I) + B(I)
      RETURN
      END
      SUBROUTINE MXINV (A, N, D, L, M)
C
C     ******************************************************************
C
C     SUBROUTINE MXINV INVERTS A DOUBLE PRECISION MATRIX IN VECTOR
C     STORAGE MODE BY USING THE GAUSS-JORDAN METHOD.  THE DETERMINANT IS
C     CALCULATED BUT IS ZERO IF THE MATRIX BEING INVERTED IS SINGULAR.
C     MXINV DOES NOT CALL ANY SUBROUTINES.  MXINV IS CALLED BY
C     SUBROUTINES AES800, CTBL, LAPNV, AND RICSS.
C
C     INPUTS:
C
C              A       MATRIX TO BE INVERTED, VECTOR STORAGE MODE (N,N)
C              N       ACTUAL SIZE OF MATRIX A
C
C     OUTPUTS:
C
C              A       MATRIX INVERTED FORM, VECTOR STORAGE MODE (N,N)
C              D       SCALAR DETERMINANT (ZERO IF MATRIX A IS SINGULAR)
C
C     TEMPORARY STORAGE:
C
C              L       INTEGER VECTOR (N)
C              M       INTEGER VECTOR (N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1), L(1), M(1)
C
C     FIND LARGEST ELEMENT
C
      D = 1.0
      NN =  - N
      DO 80  K = 1,N
      NN = NN + N
      KK = NN + K
      L(K) = K
      M(K) = K
      ALAR = A(KK)
      DO 20  J = K,N
      II = N * (J - 1)
      DO 20  I = K,N
      IJ = II + I
      IF (DABS(ALAR) - DABS(A(IJ)))  15,20,20
   15 ALAR = A(IJ)
      L(K) = I
      M(K) = J
   20 CONTINUE
C
C     EXCHANGE ROWS
C
      J = L(K)
      IF (J - K)  35,35,25
   25 KN = K - N
      DO 30  I = 1,N
      KN = KN + N
      JI = KN - K + J
      EXT =  - A(KN)
      A(KN) = A(JI)
   30 A(JI) = EXT
C
C     EXCHANGE COLUMNS
C
   35 I = M(K)
      IF (I - K)  45,45,38
   38 JL = N * (I - 1)
      DO 40  J = 1,N
      JM = NN + J
      JI = JL + J
      EXT =  - A(JM)
      A(JM) = A(JI)
   40 A(JI) = EXT
   45 IF (ALAR)  48,46,48
   46 D = 0.0
      RETURN
   48 DO 55  I = 1,N
      IF (I - K)  50,55,50
   50 IK = NN + I
      A(IK) = A(IK) / ( - ALAR)
   55 CONTINUE
C
C     REDUCE MATRIX
C
      DO 65  I = 1,N
      IK = NN + I
      IJ = I - N
      DO 65  J = 1,N
      IJ = IJ + N
      IF (I - K)  60,65,60
   60 IF (J - K)  62,65,62
   62 KJ = IJ - I + K
      A(IJ) = A(IK) * A(KJ) + A(IJ)
   65 CONTINUE
      KJ = K - N
      DO 75  J = 1,N
      KJ = KJ + N
      IF (J - K)  70,75,70
   70 A(KJ) = A(KJ) / ALAR
   75 CONTINUE
      A(KK) = 1.0 / ALAR
      D = D * ALAR
   80 CONTINUE
C
C     FINAL ROW AND COLUMN EXCHANGE
C
      K = N
  100 K = K - 1
      IF (K)  150,150,105
  105 I = L(K)
      IF (I - K)  120,120,108
  108 JN = N * (K - 1)
      JK = N * (I - 1)
      DO 110  J = 1,N
      JM = JN + J
      JI = JK + J
      EXT = A(JM)
      A(JM) =  - A(JI)
  110 A(JI) = EXT
  120 J = M(K)
      IF (J - K)  100,100,125
  125 KN = K - N
      DO 130  I = 1,N
      KN = KN + N
      JI = KN - K + J
      EXT = A(KN)
      A(KN) =  - A(JI)
  130 A(JI) = EXT
      GO TO 100
  150 RETURN
      END
      SUBROUTINE MXMLT (A, B, R, N, L, M)
C
C     ******************************************************************
C
C     SUBROUTINE MXMLT MULTIPLIES TWO MATRICES IN VECTOR STORAGE MODE
C     TO FORM A RESULTANT MATRIX IN VECTOR STORAGE MODE.  MXMLT DOES
C     NOT CALL ANY SUBROUTINES.  MXMLT IS CALLED BY SUBROUTINE LAPNV.
C
C     INPUTS:
C
C              A       FIRST INPUT MATRIX (N,L)
C              B       FIRST INPUT MATRIX (L,M)
C              N       NUMBER OF ROWS IN MATRIX A
C              L       NUMBER OF COLUMNS IN MATRIX A
C                      AND ROWS IN MATRIX B
C              M       NUMBER OF COLUMNS IN MATRIX B
C
C     OUTPUTS:
C
C              R       OUTPUT MATRIX (N,M)
C
C     ******************************************************************
C
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION A(1),B(1),R(1)
C
C
C
      IR = 0
      IK = - L
      DO 10  K = 1,M
      IK = IK + L
      DO 10  J = 1,N
      IR = IR + 1
      JI = J - N
      IB = IK
      R(IR) = 0
      DO 10  I = 1,L
      JI = JI + N
      IB = IB + 1
   10 R(IR) = R(IR) + A(JI) * B(IB)
      RETURN
      END
      SUBROUTINE MXTRA (A, R, N, M)
C
C     ******************************************************************
C
C     SUBROUTINE MXTRA TRANSPOSES AN N BY M MATRIX A IN VECTOR STORAGE
C     MODE TO FORM AN M BY N MATRIX R IN VECTOR STORAGE MODE.  MXTRA
C     DOES NOT CALL ANY SUBROUTINES.  MXTRA IS CALLED BY SUBROUTINE
C     LAPNV.
C
C     INPUTS:
C
C              A       MATRIX TO BE TRANSPOSED (N,M)
C              N       NUMBERS OF ROWS IN MATRIX A
C                      AND COLUMNS IN MATRIX R
C              M       NUMBERS OF COLUMNS IN MATRIX A
C                      AND ROWS IN MATRIX R
C
C     OUTPUTS:
C
C              R       RESULTANT MATRIX (M,N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION A(1),R(1)
C
C
C
      IR = 0
      DO 10  I = 1,N
      IJ = I - N
      DO 10  J = 1,M
      IJ = IJ + N
      IR = IR + 1
   10 R(IR) = A(IJ)
      RETURN
      END
      SUBROUTINE NRML (A, B, C, H, Q, RINV, D, DOUT, CSP, N, NC, NO, NM,
     * ND, NMAX, NCMAX, NOMAX, NMMAX, FL34)
C
C     ******************************************************************
C
C     SUBROUTINE NRML READS FOUR NORMALIZATION VECTORS FROM NAMELIST
C     NRMS AND NORMALIZES THE A, B, C, H, Q, RINV, D, DOUT, AND CSP
C     MATRICES.  THE SYSTEM THUS REPRESENTED IS DEFINED BY NORMALIZED
C     STATE, CONTROL, OUTPUT, MEASUREMENT, AND SET POINT VECTORS.
C     THE NORMALIZATION VECTORS ARE TRANSFERRED TO THE MAIN PROGRAM
C     THROUGH COMMON 'NORMS'.  NRML DOES NOT CALL ANY SUBROUTINES.
C     NRML IS CALLED BY SUBROUTINE AES400.
C
C     INPUTS:
C
C              A       UN-NORMALIZED SYSTEM MATRIX (N,N)
C              B       UN-NORMALIZED CONTROL INPUT MATRIX (N,NC)
C              C       UN-NORMALIZED OUTPUT MATRIX (NO,N)
C              H       UN-NORMALIZED MEASUREMENT MATRIX (NM,N)
C              Q       UN-NORMALIZED POWER SPECTRAL DENSITY MATRIX OF
C                      PLANT DISTURBANCE (N,N)
C              RINV    UN-NORMALIZED INVERSE OF POWER SPECTRAL DENSITY
C                      MATRIX OF MEASUREMENT NOISE (NM,NM)
C              D       UN-NORMALIZED DISTURBANCE INPUT MATRIX (N,ND)
C              DOUT    UN-NORMALIZED FEED FORWARD MATRIX FOR
C                      NON-ZERO SET POINT REGULATOR (NO,NC)
C              CSP     UN-NORMALIZED SET POINT OUTPUT MATRIX (NC,N)
C              N       ACTUAL NUMBER OF STATES
C              NC      ACTUAL NUMBER OF CONTROL INPUTS
C              NO      ACTUAL NUMBER OF OUTPUTS
C              NM      ACTUAL NUMBER OF MEASUREMENTS
C              ND      ACTUAL NUMBER OF DISTURBANCE INPUTS
C              NMAX    MAXIMUM SIZE OF N
C              NCMAX   MAXIMUM SIZE OF NC
C              NOMAX   MAXIMUM SIZE OF NO
C              NMMAX   MAXIMUM SIZE OF NM
C              FL34    LOGICAL VARIABLE, ON INPUT
C                      TRUE, NORMALIZATION VECTOR INFORMATION
C                      (NAMELIST NRMS) HAS ALREADY BEEN READ IN
C                      FALSE, NORMALIZATION VECTOR INFORMATION
C                      (NAMELIST NRMS) NEEDS TO BE READ IN
C
C     OUTPUTS:
C
C              A       NORMALIZED SYSTEM MATRIX (N,N)
C              B       NORMALIZED CONTROL INPUT MATRIX (N,NC)
C              C       NORMALIZED OUTPUT MATRIX (NO,N)
C              H       NORMALIZED MEASUREMENT MATRIX (NM,N)
C              Q       NORMALIZED POWER SPECTRAL DENSITY MATRIX OF
C                      PLANT DISTURBANCE (N,N)
C              RINV    NORMALIZED INVERSE OF POWER SPECTRAL DENSITY
C                      MATRIX OF MEASUREMENT NOISE (NM,NM)
C              D       NORMALIZED DISTURBANCE INPUT MATRIX (N,ND)
C              DOUT    NORMALIZED FEED FORWARD MATRIX FOR
C                      NON-ZERO SET POINT REGULATOR (NO,NC)
C              CSP     NORMALIZED SET POINT OUTPUT MATRIX (NC,N)
C              FL34    LOGICAL VARIABLE, ON OUTPUT SET TO
C                      TRUE IF NORMALIZATION VECTOR INFORMATION
C                      (NAMELIST NRMS) HAS BEEN READ IN
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL FL34
      DIMENSION A(NMAX,1), B(NMAX,1), C(NOMAX,1), H(NMMAX,1),
     * Q(NMAX,1), RINV(NMMAX,1), D(NMAX,1), DOUT(NOMAX,1), CSP(NCMAX,1)
      COMMON /NORMS/  SCX(50), SCU(5), SCY(50), SCZ(5), SCYSP(5)
      NAMELIST /NRMS/  SCX, SCU, SCY, SCZ, SCYSP
C
C
C
      IF (FL34)  GO TO 10
      DO 5  K = 1,N
    5 SCX(K) = 1.0D0
      DO 7  K = 1,NC
      SCYSP(K) = 1.0D0
    7 SCU(K) = 1.0D0
      DO 8  K = 1,NO
    8 SCY(K) = 1.0D0
      DO 9  K = 1,NM
    9 SCZ(K) = 1.0D0
      WRITE (2,100)
      PAUSE
      READ (34,NRMS)
      FL34 = .TRUE.
   10 CONTINUE
      WRITE (2,60)
      WRITE (6,60)
      WRITE (2,NRMS)
      WRITE (6,NRMS)
      DO 50  I = 1,N
      DO 15  J = 1,ND
   15 D(I,J) = D(I,J) / SCX(I)
      DO 20  J = 1,NC
      CSP(J,I) = CSP(J,I) * SCX(I) / SCYSP(J)
   20 B(I,J) = B(I,J) * SCU(J) / SCX(I)
      DO 30  J = 1,NM
   30 H(J,I) = H(J,I) * SCX(I) / SCZ(J)
      DO 40  J = 1,NO
   40 C(J,I) = C(J,I) * SCX(I) / SCY(J)
      DO 50  J = 1,N
      Q(I,J) = Q(I,J) / SCX(J) / SCX(I)
   50 A(I,J) = A(I,J) * SCX(J) / SCX(I)
      DO 70  I = 1,NO
      DO 70  J = 1,NC
   70 DOUT(I,J) = DOUT(I,J) * SCU(J) / SCY(I)
      DO 80  I = 1,NM
      DO 80  J = 1,NM
   80 RINV(I,J) = RINV(I,J) * SCZ(J) * SCZ(I)
      RETURN
C
C
C     FORMATS
C
C
   60 FORMAT (1H0 / 1X, 'NORMALIZING FACTORS ARE')
  100 FORMAT (1X, 'IF NOT ALREADY DONE, DDEF DATASET CONTAINING NAMELIST
     * ''NRMS'' TO UNIT 34')
      END
      SUBROUTINE OBSBL (H, T, CI, HT, EX1, N, NR, NRMAX, NMAX)
C
C     ******************************************************************
C
C     SUBROUTINE OBSBL COMPUTES THE OBSERVABILITY MATRIX HT FOR THE
C     LINEAR SYSTEM DESCRIBED BY XDOT=A*X + B*U, AND Y=H*X.
C     NOTE: FOR A COMPLEX EIGENVALUE PAIR, THE CORRESPONDING TWO COLUMN
C     ELEMENTS IN HT ARE STORED AS MAGNITUDE AND ANGLE (IN DEGREES)
C     RESPECTIVELY.
C     OBSBL CALLS SUBROUTINE MATPRT.  OBSBL IS CALLED BY SUBROUTINE
C     AES400.
C
C     INPUTS:
C
C              H       SYSTEM OUTPUT MATRIX (NR,N)
C              T       MODIFIED EIGENVECTOR MATRIX OF MATRIX A (N,N)
C              CI      VECTOR OF IMAG PARTS OF THE EIGENVALUES (N)
C                      (OF MATRIX A)
C              N       ACTUAL NUMBER OF COLUMNS IN MATRIX H
C              NR      ACTUAL NUMBER OF ROWS IN MATRIX H
C              NRMAX   MAXIMUM SIZE OF NR
C              NMAX    MAXIMUM SIZE OF N
C
C     OUTPUTS:
C
C              HT      OBSERVABILITY MATRIX (NR,N)
C                      (IN MAGNITUDE AND PHASE ANGLE FORM)
C              EX1     OBSERVABILITY MATRIX (NR,N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  H(NRMAX,1), T(NMAX,1), CI(1), HT(NRMAX,1), EX1(NRMAX,1)
C
C
C
      DO 10  J = 1,N
      DO 10  I = 1,NR
      SUM = 0.0D0
      DO 9  K = 1,N
    9 SUM = SUM + H(I,K) * T(K,J)
      HT(I,J) = SUM
   10 EX1(I,J) = SUM
      DO 60  I = 1,NR
      J = 1
   35 CONTINUE
      IF (J .GT. N)  GO TO 50
      IF (CI(J)  .EQ. 0.) GO TO 40
      Y1 = HT(I,J)
      Y2 = HT(I,J+1)
      IF (Y1 .NE. 0.0 .AND. Y2 .NE. 0.0)  GO TO 36
      HT(I,J) = 0.0
      HT(I,J+1) = 0.0
      GO TO 37
   36 CONTINUE
      HT(I,J) = DSQRT((Y1 * Y1 + Y2 * Y2) / 2.)
      HT(I,J+1) = DATAN2(Y2 - Y1, Y2 + Y1) * 57.29578
   37 J = J + 2
      GO TO 35
   40 CONTINUE
      J = J + 1
      GO TO 35
   50 CONTINUE
   60 CONTINUE
      WRITE (6,100)
      CALL MATPRT (HT, NR, N, NRMAX)
      RETURN
C
C
C     FORMATS
C
C
  100 FORMAT (1X, 'OBSERVABILITY MATRIX' / 1X, 'FOR COMPLEX EIGENVALUES,
     * MAG. AND ANGLE(DEG.) ARE DISPLAYED')
      END
      SUBROUTINE ORDER (CR, CI, NE, EPS)
C
C     ******************************************************************
C
C     GIVEN A SET OF NE EIGENVALUES, SYMMETRICALLY LOCATED WITH RESPECT
C     TO THE IMAGINARY AXIS, SUBROUTINE ORDER PLACES ONES WITH POSITIVE
C     REAL PARTS IN FIRST NE/2 LOCATIONS.  CORRESPONDING SYMMETRIC
C     EIGENVALUES WITH NEGATIVE REAL PARTS ARE PUT IN LOCATIONS
C     NE/2 + 1 THROUGH NE.  EPS IS THE CONVERGENCE CRITERION USED IN
C     DETERMINING IF A PAIR OF EIGENVALUES ARE SYMMETRIC.
C     ORDER DOES NOT CALL ANY SUBROUTINES.  ORDER IS CALLED BY
C     SUBROUTINE RICSS.
C
C     INPUTS:
C
C              CR      VECTOR OF REAL PARTS OF EIGENVALUES
C                      UNORDERED (NE)
C              CI      VECTOR OF IMAGINARY PARTS OF EIGENVALUES
C                      UNORDERED (NE)
C              NE      NUMBER OF EIGENVALUES
C              EPS     CRITERION FOR SYMMETRY
C
C     OUTPUTS:
C
C              CR      VECTOR OF REAL PARTS OF EIGENVALUES
C                      ORDERED (NE)
C              CI      VECTOR OF IMAGINARY PARTS OF EIGENVALUES
C                      ORDERED (NE)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  CR(1), CI(1)
C
C
C
      NE2 = NE / 2
      KMAX = NE2 + 1
      IMAX = NE + 1
      K = 0
C
C     PUT EIGENVALUES WITH POSITIVE REAL PARTS IN TOP HALVES OF CR AND
C     CI AND REST IN BOTTOM HALVES
C
   10 K = K + 1
   20 IF (K .EQ. KMAX)  GO TO 40
      IF (CR(K)  .GT. 0.0) GO TO 10
      TCR = CR(K)
      TCI = CI(K)
      I = K + 1
   30 L = I - 1
      CR(L) = CR(I)
      CI(L) = CI(I)
      I = I + 1
      IF (I .NE. IMAX)  GO TO 30
      CR(NE) = TCR
      CI(NE) = TCI
      GO TO 20
   40 CONTINUE
      K = 0
C
C     REARRANGE EIGENVALUES WITH NEGATIVE REAL PARTS SO THAT
C     CR(I + NE/2) = -CR(I)
C
   50 K = K + 1
      L = NE2 + K
      IF (K .EQ. KMAX)  GO TO 80
   60 IF (DABS((CR(K) + CR(L)) / CR(K)) .LT. EPS)  GO TO 70
      L = L + 1
      IF (L .LE. NE)  GO TO 60
      WRITE (6,90)
      WRITE (2,90)
      STOP
   70 TCR = CR(L)
      TCI = CI(L)
      M = NE2 + K
      CR(L) = CR(M)
      CI(L) = CI(M)
      CR(M) = TCR
      CI(M) = TCI
      GO TO 50
   80 CONTINUE
      DO 85  I = 1,NE2
      J = NE2 + I
      CR(I) = DSIGN((DABS(CR(I)) + DABS(CR(J))) / 2.0, CR(I))
      CR(J) = DSIGN(CR(I), CR(J))
      CI(I) = DSIGN((DABS(CI(I)) + DABS(CI(J))) / 2.0, CI(I))
   85 CI(J) = DSIGN(CI(I), CI(J))
      RETURN
C
C
C     FORMAT
C
C
   90 FORMAT (1X, 'EIGENVALUES ARE NOT SYMMETRIC')
      END
      SUBROUTINE POLMPY (X, Y, Z, NX, NY, NZ)
C
C     ******************************************************************
C
C     SUBROUTINE POLMPY MULTIPLIES X*Y=Z (THE LEADING POLYNOMIAL
C     COEFFICIENT IS ASSUMED TO BE UNITY).
C     POLMPY DOES NOT CALL ANY SUBROUTINES.  POLMPY IS CALLED BY
C     SUBROUTINE DANSKY.
C
C     INPUTS:
C
C              X       POLYNOMIAL COEFFIENT VECTOR (NX)
C              Y       POLYNOMIAL COEFFIENT VECTOR (NY)
C              NX      ORDER OF POLYNOMIAL FOR WHICH VECTOR X IS THE
C                      LIST OF COEFFICIENTS (OTHER THAN THE FIRST)
C              NY      ORDER OF POLYNOMIAL FOR WHICH VECTOR Y IS THE
C                      LIST OF COEFFICIENTS (OTHER THAN THE FIRST)
C
C     OUTPUTS:
C
C              Z       X VECTOR * Y VECTOR (NZ)
C              NZ      ORDER OF POLYNOMIAL FOR WHICH VECTOR Z IS THE
C                      LIST OF COEFFICIENTS (OTHER THAN THE FIRST)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION X(1), Y(1), Z(1)
C
C
C
      NZ = NX + NY
C     IF NX=0 MEANS POLY X=1;THEREFORE Z=Y
      IF (NX .GT. 0)  GO TO 6
      DO 4  J = 1,NY
    4 Z(J) = Y(J)
      GO TO 40
C     IF NY=0 MEANS POLY Y=1;THEREFORE Z=X
    6 IF (NY .GT. 0)  GO TO 15
      DO 8  J = 1,NX
    8 Z(J) = X(J)
      GO TO 40
C     START MULTIPLICATION BY MAKING Z=Y*S**NX
   15 DO 20  J = 1,NZ
      YJ = Y(J)
      IF (J .GT. NY)  YJ = 0.
   20 Z(J) = YJ
C     MULTIPLICATION LOOP
      DO 30  K = 1,NX
      Z(K) = Z(K) + X(K)
      DO 25  J = 1,NY
      KPJ = K + J
   25 Z(KPJ) = Z(KPJ) + Y(J) * X(K)
   30 CONTINUE
   40 RETURN
      END
      SUBROUTINE PREREQ (WHEN, IFN, IAND, MZ, II)
C
C     ******************************************************************
C
C     SUBROUTINE PREREQ CHECKS TO SEE IF PREREQUISITE FUNCTIONS HAVE
C     BEEN DONE FOR THE FUNCTION ABOUT TO BE RUN.  IF NOT, IT PRINTS OUT
C     WHAT THE PREREQUISITES ARE.  PREREQ DOES NOT CALL ANY SUBROUTINES.
C     PREREQ IS CALLED BY SUBROUTINES AES100, AES200, AES300, AES400,
C     AES500, AES600, AES700, AND AES800.
C
C     INPUTS:
C
C              WHEN    LOGICAL MATRIX OF PREREQS (450,50)
C              IFN     VECTOR OF FUNCTION NUMBERS TO BE DONE (1000)
C              MZ      WHICH FUNCTION IS TO BE CHECKED FOR PREREQUISITES
C              II      WHICH ROW OF MATRIX 'WHEN' IS TO BE LOOKED AT
C
C     OUTPUTS:
C
C              IAND    DECISION VARIABLE, 0 IF PREREQUISITES HAVE BEEN
C                      DONE, 1 IF PREREQUISITES HAVE NOT BEEN DONE
C
C     ******************************************************************
C
      LOGICAL  WHEN
      DIMENSION  IFN(1000), WHEN(450,50)
      DIMENSION  VFMT(10,50), VFMT1(10,15), VFMT2(10,15), VFMT3(10,15),
     * VFMT4(10,5), FMT(10)
      EQUIVALENCE  (VFMT1(1,1),VFMT(1,1)), (VFMT2(1,1),VFMT(1,16)),
     * (VFMT3(1,1),VFMT(1,31)), (VFMT4(1,1),VFMT(1,46))
      DATA  VFMT1 /    10 * 4H    , 4H( ' , 4H(201, 4H OR , 4H202),
     * 5 * 4H    , 4H ' ), 4H( ' , 4H(205, 4H OR , 4H801), 5 * 4H    ,
     * 4H ' ), 4H( ' , 4H(206, 4H OR , 4H809), 5 * 4H    , 4H ' ),
     * 4H( ' , 4H(207, 4H OR , 4H801), 5 * 4H    , 4H ' ), 4H( ' ,
     * 4H(208, 4H OR , 4H809), 5 * 4H    , 4H ' ), 4H( ' , 4H(301,
     * 4H)   , 6 * 4H    , 4H ' ), 4H( ' , 4H(302, 4H)   , 6 * 4H    ,
     * 4H ' ), 4H( ' , 4H(303, 4H)   , 6 * 4H    , 4H ' ), 4H( ' ,
     * 4H(205, 4H OR , 4H206 , 4HOR 8, 4H01 O, 4HR 80, 4H9)  ,  4H    ,
     * 4H ' ), 4H( ' , 4H(401, 4H)   , 6 * 4H    , 4H ' ), 4H( ' ,
     * 4H(402, 4H)   , 6 * 4H    , 4H ' ), 4H( ' , 4H(404, 4H)   ,
     *6 * 4H    , 4H ' ), 4H( ' , 4H(501, 4H)   , 6 * 4H    , 4H ' ),  4
     *H( ' , 4H(504, 4H)   , 6 * 4H    , 4H ' ) /
      DATA  VFMT2 /    4H( ' , 4H(507, 4H)   , 6 * 4H    , 4H ' ),
     * 4H( ' , 4H(510, 4H)   , 4H    , 4H    , 4H    , 4H    , 4H    ,
     * 4H    , 4H ' ), 4H( ' , 4H(513, 4H)   , 6 * 4H    , 4H ' ),
     * 4H( ' , 4H(515, 4H)   , 6 * 4H    , 4H ' ), 4H( ' , 4H(517,
     * 4H)   , 6 * 4H    , 4H ' ), 4H( ' , 4H(519, 4H)   , 6 * 4H    ,
     * 4H ' ), 4H( ' , 4H(521, 4H)   , 6 * 4H    , 4H ' ), 4H( ' ,
     * 4H(523, 4H)   , 6 * 4H    , 4H ' ), 4H( ' , 4H(801, 4H)   ,
     * 6 * 4H    , 4H ' ), 4H( ' , 4H(803, 4H)   , 6 * 4H    , 4H ' ),
     * 4H( ' , 4H(809, 4H)   , 6 * 4H    , 4H ' ), 4H( ' , 4H(817,
     * 4H)   , 6 * 4H    , 4H ' ), 4H( ' , 4H(209, 4H OR , 4H819),
     * 5 * 4H    , 4H ' ), 20 * 4H     /                                
      DATA  VFMT3 / 150 * 4H      /
      DATA  VFMT4 /  50 * 4H      /
      DATA  YES / 1HY /
C
C
C
      IAND = 0
      DO 2  I = 1,50
      IF (WHEN(II,I))  GO TO 2
      IF (IAND .EQ. 0)  WRITE (2,3)  IFN(MZ)
      IF (IAND .EQ. 1)  WRITE (2,4)
      DO 1  K = 1,10
    1 FMT(K) = VFMT(K,I)
      WRITE (2,FMT)
      IAND = 1
    2 CONTINUE
      IF (IAND .EQ. 0)  RETURN
      WRITE (2,5)
      READ (2,6)  YON
      IF (YON .EQ. YES)  IAND = 0
      RETURN
C
C
C     FORMATS
C
C
    3 FORMAT (1X, 'YOU HAVE NOT EXECUTED THE FOLLOWING PREREQUISITE FUNC
     *TION(S) FOR FUNCTION ', I4)
    4 FORMAT (1X, 'AND')
    5 FORMAT (1X, 'IF YOU THINK YOU KNOW WHAT YOU ARE DOING AND WISH TO
     *IGNORE THE PREREQS' / 1X 'AND CONTINUE ON TO DO THIS FUNCTION, TYP
     *E Y AND RETURN;' / 1X, 'OTHERWISE, JUST RETURN')
    6 FORMAT  (A1)
      END
      SUBROUTINE PRMUTE (X, ITRANS, IA, NE, LA, NEMAX)
C
C     ******************************************************************
C
C     SUBROUTINE PRMUTE PERMUTES ELEMENTS IN LA COLUMN OF NE BY NE
C     MATRIX X AS DICTATED BY TRANSPOSITION VECTOR ITRANS. ITRANS IS
C     PRODUCED, IN THIS CASE, BY SUBROUTINE FACTR.
C     PRMUTE DOES NOT CALL ANY SUBROUTINES.  PRMUTE IS CALLED BY
C     SUBROUTINE EGVCTR.
C
C     INPUTS:
C
C              X       MATRIX TO BE PERMUTED (NE,NE)
C              ITRANS  TRANSPOSITION VECTOR (NE)
C              NE      ACTUAL SIZE OF MATRIX X
C              LA      SPECIFIC COLUMN OF MATRIX X TO BE PERMUTED BY
C                      THE TRANSPOSITION VECTOR ITRANS
C              NEMAX   MAXIMUM SIZE OF NE
C
C     OUTPUTS:
C
C              X       INPUT MATRIX IN PERMUTED FORM (NE,NE)
C
C     TEMPORARY STORAGE:
C
C              IA      INTEGER VECTOR (NE)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  X(NEMAX,1), ITRANS(1), IA(1)
C
C
C
      DO 10  I = 1,NE
   10 IA(I) = I
      DO 60  JJ = 1,NE
      J = NE + 1 - JJ
      ITRN = ITRANS(J)
      I = 0
   20 I = I + 1
      IF (IA(I) .EQ. ITRN)  GO TO 30
      GO TO 20
   30 L = 0
   40 L = L + 1
      IF (IA(L) .EQ. J)  GO TO 50
      GO TO 40
   50 XTEMP = X(L,LA)
      X(L,LA) = X(I,LA)
      X(I,LA) = XTEMP
      IA(L) = ITRN
      IA(I) = J
   60 CONTINUE
      RETURN
      END
      SUBROUTINE REDU (VARO, SS, S, IN, JBL, INBL, IOR, NBL, IBL, IC, N,
     * NMAX)
C
C     ******************************************************************
C
C     SUBROUTINE REDU USES HARARYS METHOD FOR REDUCTION OF A REDUCIBLE
C     MATRIX TO BLOCK DIAGONAL FORM.  REDU DOES NOT CALL ANY SUBROUTINE.
C     REDU IS CALLED BY SUBROUTINE CONDI.
C
C     INPUTS:
C
C              VARO    MATRIX TO BE REDUCED (N,N)
C              N       ACTUAL SIZE OF MATRIX VARO
C              NMAX    MAXIMUM SIZE OF N
C
C     OUTPUTS:
C
C              S       BLOCK DIAGONAL MATRIX (N,N)
C              INBL    NUMBER OF REDUCIBLE BLOCKS
C              IOR     BLOCK-DIAGONALIZING PERMUTATION INTEGER
C                      VECTOR (N)
C              NBL     INTEGER VECTOR OF SIZES OF EACH IRREDUCIBLE
C                      BLOCK (N)
C
C     TEMPORARY STORAGE:
C
C              SS      MATRIX (N,N)
C              IN      INTEGER VECTOR (N)
C              JBL     INTEGER VECTOR (N)
C              IBL     INTEGER VECTOR (N)
C              IC      INTEGER VECTOR (N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  VARO(NMAX,1), SS(NMAX,1), S(NMAX,1), IN(1), JBL(1),
     * IOR(1), NBL(1), IBL(1), IC(1)
C
C
C
      INBL = 0
      DO 5  I = 1,N
      IN(I) = 0
      JBL(I) = 0
      IOR(I) = 0
      NBL(I) = 0
      IC(I) = 0
    5 IBL(I) = 0
C
C     TAKE S MATRIX WHICH IS VARO MATRIX TO THE N-1 POWER IN BOOLEAN
C
      DO 10  J = 1,N
      IN(J) = J
      DO 10  I = 1,N
   10 SS(I,J) = VARO(I,J)
      IF (N .GT. 2)  GO TO 30
      DO 20  J = 1,N
      DO 20  I = 1,N
      S(I,J) = 0.0
      IF (VARO(I,J) .NE. 0.0)  S(I,J) = 1.0
   20 CONTINUE
      GO TO 80
   30 N2 = N - 2
      DO 70  L = 1,N2
      DO 60  I = 1,N
      DO 60  K = 1,N
      S(K,I) = 0.0
      DO 40  J = 1,N
      IF (VARO(K,J) .NE. 0.0D0 .AND. SS(J,I) .NE. 0.0D0)  GO TO 50
   40 CONTINUE
      GO TO 60
   50 S(K,I) = 1.0
   60 CONTINUE
      DO 70  J = 1,N
      DO 70  I = 1,N
   70 SS(I,J) = S(I,J)
C
C     FIND EQUIVALENCE BLOCKS AND IDENTIFY
C
   80 INBL = 1
      KSUM = 1
   90 KSUMO = KSUM
      DO 130  I = 1,N
      DO 130  J = 1,N
      IF (I .EQ. J)  GO TO 130
      IF (S(I,J) .NE. S(J,I))  GO TO 130
      IF (IN(I) .EQ. 0 .AND. IN(J) .EQ. 0)  GO TO 130
      IF (S(I,J) .EQ. 0.0 .AND. S(J,I) .EQ. 0.0)  GO TO 130
      IF (KSUMO .NE. KSUM)  GO TO 100
      IN(I) = 0
      IOR(KSUM) = I
      IN(J) = 0
      IOR(KSUM+1) = J
      KSUM = KSUM + 2
      GO TO 130
  100 K1 = KSUM - 1
      DO 110  L = KSUMO,K1
      IF (IOR(L) .NE. I)  GO TO 110
      IF (IN(J) .EQ. 0)  GO TO 130
      IN(J) = 0
      IOR(KSUM) = J
      KSUM = KSUM + 1
  110 CONTINUE
      DO 120  L = KSUMO,K1
      IF (IOR(L) .NE. J)  GO TO 120
      IF (IN(I) .EQ. 0)  GO TO 130
      IN(I) = 0
      IOR(KSUM) = I
      KSUM = KSUM + 1
  120 CONTINUE
  130 CONTINUE
      IF (KSUMO .NE. KSUM)  GO TO 150
      DO 140  I = 1,N
      IF (IN(I) .EQ. 0)  GO TO 140
      NBL(INBL) = 1
      INBL = INBL + 1
      IOR(KSUM) = IN(I)
      IN(I) = 0
      KSUM = KSUM + 1
  140 CONTINUE
      INBL = INBL - 1
      KSUM = KSUM - 1
      GO TO 180
  150 NBL(INBL) = KSUM - KSUMO
      NSUM = 0
      DO 160  I = 1,INBL
      NSUM = NBL(I) + NSUM
  160 CONTINUE
      IF (NSUM .NE. N)  GO TO 170
      KSUM = KSUM - 1
      GO TO 180
  170 INBL = INBL + 1
      GO TO 90
C
C     REARRANGE MATRIX TO FORM EQUIVALENCE BLOCKS
C
  180 DO 190  J = 1,N
      DO 190  I = 1,N
      K = IOR(I)
  190 SS(I,J) = VARO(K,J)
      DO 200  J = 1,N
      K = IOR(J)
      DO 200  I = 1,N
  200 S(I,J) = SS(I,K)
C
C     MAKE BOOLEAN MATRIX FROM EQUIVALENCE BLOCKS
C
      NSUM = 0
      DO 210  L = 1,INBL
      NSMOLD = NSUM + 1
      NSUM = NSUM + NBL(L)
      JSUM = 0
      DO 210  K = 1,INBL
      JSMOLD = JSUM + 1
      JSUM = JSUM + NBL(K)
      SS(L,K) = 0.0
      DO 210  J = JSMOLD,JSUM
      DO 210  I = NSMOLD,NSUM
      IF (S(I,J) .NE. 0.0)  SS(L,K) = 1.0
  210 CONTINUE
      DO 220  I = 1,INBL
      IBL(I) = NBL(I)
      IF (SS(I,I) .NE. 1.0)  SS(I,I) = 1.0
  220 CONTINUE
C
C     REARRANGE EQUIVALENCE BLOCKS IN ORDER OF BOOLEAN COLUMNS WITH
C     DECREASING NUMBERS OF ZEROES
C     S = MATRIX IN EQUIVALENCE BLOCK ORDER
C     INBL = NUMBER OF EQUIVALENCE BLOCKS
C     NBL(I) = SIZE OF ITH BLOCK,  (I = 1,...INBL)
C     IBL(I) = NBL(I)
C     IOR(J) = NEW ORDER OF ROWS AND COLUMNS OF S IN COMPARISON
C              WITH VARO,  (J = 1,...N)
C     SS = BOOLEAN MATRIX OF EQUIVALENCE BLOCKS IN S
C
      INEW = INBL
      INUM = 0
      IVAR = 1
  230 IMAX = 0
      IZERMX = 0
      DO 250  J = 1,INBL
      IZER = 0
      DO 240  I = 1,INBL
      IF (INUM .EQ. 0)  GO TO 245
      DO 235  JJJ = 1,INUM
      IF (J .EQ. IC(JJJ))  GO TO 250
      IF (I .EQ. IC(JJJ))  GO TO 240
  235 CONTINUE
  245 IF (SS(I,J) .EQ. 0.0)  IZER = IZER + 1
  240 CONTINUE
      IF (IZER .LE. IZERMX)  GO TO 250
      IZERMX = IZER
      IMAX = J
  250 CONTINUE
      INUM = INUM + 1
      IC(INUM) = IMAX
      KBL = INBL - INEW + 1
      IF (IMAX .EQ. 0)  GO TO 260
      JBL(KBL) = IBL(IMAX)
      IBL(IMAX) = 0
      GO TO 290
  260 DO 280  I = KBL,INBL
      DO 270  J = 1,INBL
      IF (IBL(J) .EQ. 0)  GO TO 270
      JBL(I) = IBL(J)
      IBL(J) = 0
      GO TO 280
  270 CONTINUE
  280 CONTINUE
  290 IF (IZERMX .EQ. 0)  GO TO 340
      NSUM = 0
      DO 300  I = 1,IMAX
  300 NSUM = NSUM + NBL(I)
      NSMOLD = NSUM - NBL(IMAX) + 1
      DO 310  I = NSMOLD,NSUM
      J = IVAR + I - NSMOLD
      IN(J) = IOR(I)
  310 IOR(I) = 0
      IVAR = IVAR + NSUM - NSMOLD + 1
      INEW = INEW - 1
      IF (INEW .LE. 0)  GO TO 370
      GO TO 230
  340 DO 360  I = 1,N
      IF (IN(I) .NE. 0)  GO TO 360
      DO 350  J = 1,N
      IF (IOR(J) .EQ. 0)  GO TO 350
      IN(I) = IOR(J)
      IOR(J) = 0
      GO TO 360
  350 CONTINUE
  360 CONTINUE
C
C     REARRANGE ROWS AND COLUMNS OF ORIGINAL MATRIX VARO TO FORM FINAL
C     MATRIX S IN BLOCK DIAGONAL FORM
C
  370 CONTINUE
      DO 380  I = 1,INBL
  380 NBL(I) = JBL(I)
      DO 390  J = 1,N
      DO 390  I = 1,N
      IOR(I) = IN(I)
      K = IOR(I)
  390 SS(I,J) = VARO(K,J)
      DO 400  J = 1,N
      K = IOR(J)
      DO 400  I = 1,N
  400 S(I,J) = SS(I,K)
      RETURN
      END
      SUBROUTINE RESI (C, B, EIGR, EIGI, R, EXA, N, NC, NO, NMAX, NOMAX)
C
C     ******************************************************************
C
C     SUBROUTINE RESI COMPUTES THE RESIDUE MATRICES FOR THE LINEAR
C     SYSTEM,  XDOT=A*X + B*U,    AND,   Y=C*X
C     WHERE THE SYSTEM IS ASSUMED TO BE IN BLOCK-DIAGONAL FORM.
C     MATRICES C AND B ARE INPUT TO THE PROGRAM.  MATRIX C IS ASSUMED TO
C     HAVE BEEN TRANSFORMED TO THE FORM CORRESPONDING TO BLOCK-DIAGONAL
C     A MATRIX USING SUBROUTINE OBSBL.  MATRIX B IS ASSUMED TO HAVE BEEN
C     SIMILARLY TRANSFORMED USING SUBROUTINE CTBL.
C     NOTE:  TWO RESIDUE MATRICES ARE PRINTED OUT FOR A COMPLEX
C     EIGENVALUE; THE FIRST CONTAINS RESIDUE MAGNITUDES AND THE SECOND
C     CONTAINS RESIDUE PHASE ANGLES IN DEGREES.
C     RESI CALLS SUBROUTINE MATPRT.  RESI IS CALLED BY SUBROUTINE AES400
C .
C
C     INPUTS:
C
C              C       OUTPUT MATRIX (NO,N)
C              B       INPUT MATRIX (N,NC)
C              EIGR    VECTOR OF REAL PARTS OF EIGENVALUES (N)
C              EIGI    VECTOR OF IMAGINARY PARTS OF EIGENVALUES (N)
C              N       NUMBER OF STATES
C              NC      NUMBER OF INPUTS
C              NO      NUMBER OF OUTPUTS
C              NMAX    MAXIMUM SIZE OF N
C              NOMAX   MAXIMUM SIZE OF NO
C
C     OUTPUTS:
C
C              R       RESIDUE ARRAY (N,NO,NC)
C
C     TEMPORARY STORAGE:
C
C              EXA     MATRIX (NO,NC)  TEMPORARILY STORES EACH RESIDUE
C                      MATRIX BEFORE BEING PRINTED OUT
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION C(NOMAX,1), B(NMAX,1), R(NMAX,NOMAX,1), EIGI(1),
     * EIGR(1), EXA(NOMAX,1)
C
C
C
      JJ = 0
      DO 1  KK = 1,N
      IF (JJ .EQ. 1)  GO TO 2
      IF (EIGI(KK)  .EQ. 0.) GO TO 3
C
C     COMPLEX EIGENVALUES
C
      JJ = 1
      DO 4  I = 1,NO
      DO 4  J = 1,NC
      Y1 = C(I,KK) * B(KK,J)
      Y2 = C(I,KK+1) * B(KK+1,J)
      X1 = C(I,KK) * B(KK+1,J)
      X2 = C(I,KK+1) * B(KK,J)
      R(KK,I,J) = (DSQRT(Y1 * Y1 + Y2 * Y2 + X1 * X1 + X2 * X2)) / 2.0
      IF (X1 + X2 .EQ. 0.0D0  .OR. Y1 - Y2 .EQ. 0.0D0)  GO TO 8
      GO TO 10
    8 R(KK+1,I,J) = 0.0D0
      GO TO 4
   10 CONTINUE
      R(KK+1,I,J) = DATAN2(Y1 - Y2, X1 + X2) * 57.29578
    4 CONTINUE
      GO TO 1
C
C     REAL EIGENVALUES
C
    3 CONTINUE
      DO 5  I = 1,NO
      DO 5  J = 1,NC
    5 R(KK,I,J) = C(I,KK) * B(KK,J)
    2 CONTINUE
      JJ = 0
    1 CONTINUE
      JJ = 0
      DO 40  KK = 1,N
      DO 30  I = 1,NO
      DO 30  J = 1,NC
   30 EXA(I,J) = R(KK,I,J)
      IF (JJ .EQ. 1)  GO TO 35
      IF (EIGI(KK) .EQ. 0.)  GO TO 32
      JJ = 1
   32 CONTINUE
      WRITE (6, 39)  KK, EIGR(KK), EIGI(KK)
      WRITE (6,49)
      CALL MATPRT (EXA, NO, NC, NOMAX)
      GO TO 40
   35 WRITE (6,55)
      CALL MATPRT (EXA, NO, NC, NOMAX)
      JJ = 0
   40 CONTINUE
      RETURN
C
C
C     FORMATS
C
C
   39 FORMAT (1H0, 10X, 'EIGENVALUE(', I2, ')=', G12.5, '+', G12.5,
     * '*J')
   49 FORMAT (1X, 'THE RESIDUE MAGNITUDES =')
   55 FORMAT (1X, 'THE RESIDUE PHASE ANGLES(DEG.)=')
      END
      SUBROUTINE RICCHK (AAA, S, R, N, NMAX, N2MAX)
C
C     ******************************************************************
C
C     SUBROUTINE RICCHK COMPUTES THE RESIDUAL ERROR MATRIX FOR THE
C     RICCATI EQUATION
C                  S*AAA(22)*T + AAA(22)*S - S*AAA(12)*S + AAA(21) = 0
C         OR,     -S*AAA(11) - AAA(11)*T*S - S*AAA(12)*S + AAA(21) = 0
C     WHERE
C     S=RICCATI SOLUTION MATRIX
C     AAA=THE FOUR N BY N BLOCKS OF THE HAMILTONIAN MATRIX
C     R=RESIDUAL ERROR MATRIX
C     R IS GIVEN BY
C     R= S*AAA(22)*T + AAA(22)*S - S*AAA(12)*S + AAA(21)
C     =-(S*AAA(11) + AAA(11)*T*S - S*AAA(12)*S - AAA(21))
C     RICCHK CALLS SUBROUTINE MATPRT.  RICCHK IS CALLED BY SUBROUTINE
C     AES800.
C
C     INPUTS:
C
C              AAA     HAMILTONIAN MATRIX (2 X N,2 X N)
C              S       RICCATI SOLUTION MATRIX (N,N)
C              N       ACTUAL SIZE OF MATRIX S
C              NMAX    MAXIMUM SIZE OF N
C              N2MAX   2 X NMAX
C
C     OUTPUTS:
C
C              R       RESIDUAL ERROR MATRIX (N,N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION AAA(N2MAX,1), S(NMAX,1), R(NMAX,1)
C
C
C
      IS = 1
      JS = 1
      SUM = 0.0D0
      DO 10  J = 1,N
      DO 10  I = 1,N
      II = I + N
      R(I,J) = 0.D0
      DO 9  K = 1,N
      R(I,J) = R(I,J) + S(I,K) * AAA(K,J) + AAA(K,I) * S(K,J)
      DO 9  L = 1,N
      LL = L + N
    9 R(I,J) = R(I,J) + S(I,K) * AAA(K,LL) * S(L,J)
      R(I,J) =  - R(I,J) + AAA(II,J)
      IF (DABS(SUM) .GT. DABS(R(I,J)))  GO TO 10
      SUM = R(I,J)
      IS = I
      JS = J
   10 CONTINUE
      WRITE (6,400)  IS, JS, SUM
      WRITE (2,400)  IS, JS, SUM
      WRITE (6,100)
      CALL MATPRT (R, N, N, NMAX)
      SUM = 0.0D0
      DO 20  I = 1,N
   20 SUM = SUM + R(I,I)
      WRITE (2,200)
      WRITE (6,200)
      WRITE (2,300)  SUM
      WRITE (6,300)  SUM
      RETURN
C
C
C      FORMATS
C
C
  100 FORMAT (1X, 'RESIDUAL ERROR MATRIX FOR RICCATI EQ.')
  200 FORMAT (1X, ' TRACE OF RESIDUAL =')
  300 FORMAT (1X, G12.4)
  400 FORMAT (1X, 'MAX. RESIDUAL, R(', I2, ',', I2, ')=', G12.4)
      END
      SUBROUTINE RICSS (AAA, X, OUTPUT, CR, CI, TS, XR, EXT, TT, IPER,
     * IPERN, AR, AI, ADBLE, IOP1, IOP2, N, N2, NMAX, N2MAX)
C
C     ******************************************************************
C
C     SUBROUTINE RICSS COMPUTES THE OUTPUT SOLUTION TO THE STEADY STATE
C     MATRIX RICCATI EQUATION.  THE INPUT IS AN N2 BY N2 MATRIX, AAA,
C     WHICH IS THE HAMILTONIAN MATRIX FOR KALMAN FILTER MATRIX RICCATI
C     EQUATION.  RICSS CALLS SUBROUTINES ARRAY, MXINV, EGCK, EGVCTR,
C     EIGQR, HSBG, MATPRT, MODSHP, ORDER, AND SCALEA.  RICSS IS CALLED
C     BY SUBROUTINES CONTRL AND ESTMAT.
C
C     INPUTS:
C
C              AAA     HAMILTONIAN MATRIX FOR KALMAN FILTER RICCATI
C                      EQUATION (N2,N2)
C              IOP1    SCALING PRINT OPTION: 0, NO PRINT; 1, PRINT
C              IOP2    EIGENVECTOR PRINT OPTION: 0, NO PRINT; 1, PRINT
C              N       NUMBER OF STATE VARIABLES
C              N2      DIMENSION OF HAMILTONIAN MATRIX, 2 X N
C              NMAX    MAXIMUM SIZE OF N
C              N2MAX   MAXIMUM SIZE OF N2
C
C     OUTPUTS:
C
C              X       MODIFIED EIGENVECTOR MATRIX OF AAA (N2,N2)
C              OUTPUT  RICCATI SOLUTION MATRIX (N,N)
C              CR      VECTOR OF REAL PARTS OF EIGENVALUES (N2)
C                            (OF AAA)
C              CI      VECTOR OF IMAGINARY PARTS OF EIGENVALUES (N2)
C                            (OF AAA)
C              TS      SCALING TRANSFORMATION VECTOR OF AAA (N2)
C
C     TEMPORARY STORAGE:
C
C              XR      MATRIX (N2,N2)
C              EXT     MATRIX (N2,N2)
C              TT      MATRIX (N2,N2)
C              IPER    INTEGER VECTOR (N2)
C              IPERN   INTEGER VECTOR (N2)
C              AR      VECTOR (N2)
C              AI      VECTOR (N2)
C              ADBLE   VECTOR (N X N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  AAA(N2MAX,1), X(N2MAX,1), OUTPUT(NMAX,1), CR(1), CI(1),
     * TS(1), XR(N2MAX,1), EXT(N2MAX,1), TT(N2MAX,1), IPER(1), IPERN(1),
     * AR(1), AI(1), ADBLE(1)
C
C     EPS IS THE ERROR CRITERION USED IN DETERMINING WHETHER TWO
C     EIGENVALUES ARE SYMMETRIC ABOUT THE IMAGINARY AXIS
C
      EPS = .001D0
      ISEL = 0
      IHALF = 1
C
C     PRINT OUT AAA MATRIX
C
      WRITE (6,8000)
      CALL MATPRT (AAA, N2, N2, N2MAX)
C
C     SCALE THE AAA MATRIX (AAA IS ASSUMED TO BE IRREDUCIBLE)
C
      DO 3  J = 1,N2
      DO 3  I = 1,N2
    3 XR(I,J) = AAA(I,J)
      CALL SCALEA (XR, TS, N2, IOP1, N2MAX)
C
C     TRANSFORM CONDITIONED AND SCALED AAA TO UPPER HESSENBERG
C
      CALL ARRAY (2, N2, N2, N2MAX, XR)
      CALL HSBG (N2, XR, N2)
      CALL ARRAY (1, N2, N2, N2MAX, XR)
C
C     OBTAIN EIGENVALUES OF HESSENBERG MATRIX
C
      IOP = 0
      CALL EIGQR (XR, N2, CR, CI, IOP, N2MAX)
C
C     ORDER EIGENVALUES
C
      CALL ORDER (CR, CI, N2, EPS)
C
C     CALCULATE REGULATOR/FILTER EIGENVALUES IN FN/ZETA FORM
C
C
      WRITE (6,8002)
      WRITE (2,8002)
      WRITE (6,100)
      WRITE (2,100)
      IFLAG = 0
      DO 8005  I = 1,N
      IF (IFLAG .NE. 1)  GO TO 8003
      IFLAG = 0
      GO TO 8005
 8003 CONTINUE
      ZETA = 0.0D0
      FN = 0.0D0
      OMEGAN = DSQRT(CR(I) * CR(I) + CI(I) * CI(I))
      IF (CI(I) .NE. 0.0D0)  IFLAG = 1
      IF (OMEGAN .EQ. 0.0D0)  GO TO 8004
      ZETA = CR(I) / OMEGAN
      FN = OMEGAN / 6.2832
 8004 WRITE (6,125)  FN, ZETA
      WRITE (2,125)  FN, ZETA
 8005 CONTINUE
C
C     OBTAIN MODIFIED EIGENVECTOR MATRIX, X, USING ORIGINAL AAA MATRIX
C
      CALL EGVCTR (AAA, CR, CI, X, N2, TT, EXT, AR, AI, IPERN, IPER,
     * IOP2, N2MAX, ISEL, IHALF)
C
C     PERFORM EIGENVALUE/EIGENVECTOR CHECK
C
      CALL EGCK (AAA, X, CR, CI, XR, EXT, TT, N2, N2MAX)
C
C     OBTAIN CLOSED LOOP MODE SHAPES
C
      WRITE (6,140)
      CALL MODSHP (X, TT, CI, N, N2MAX)
C
C
C     WRITE LEFT HALF OF X
C
      DO 5  J = 1,N
      DO 5  I = 1,N2
    5 X(I,J) = 100.0 * X(I,J)
      DO 40  J = 1,N
      DO 40  I = 1,N
   40 OUTPUT(I,J) = X(I,J)
C
C     INVERT X11
C
      DO 1033  J = 1,N
      DO 1033  I = 1,N
      K = N * (J - 1) + I
 1033 ADBLE(K) = OUTPUT(I,J)
      CALL MXINV (ADBLE, N, DET, IPERN, IPER)
      DO 1034  J = 1,N
      DO 1034  I = 1,N
      K = N * (J - 1) + I
 1034 OUTPUT(I,J) = ADBLE(K)
C
C     PREMULTIPLY X11 INV. BY X11 TO CHECK INVERSION
C
      DO 44  J = 1,N
      DO 44  I = 1,N
      SUM = 0.0D0
      DO 43  K = 1,N
   43 SUM = SUM + X(I,K) * OUTPUT(K,J)
   44 XR(I,J) = SUM
      IF (DET .EQ. 0.0D0)  WRITE (6,110)
      IF (DET .EQ. 0.0D0)  WRITE (2,110)
C
C     PREMULTIPLY X11 INVERSE BY X21 TO OBTAIN RICCATI SOLUTION, OUTPUT
C
      DO 70  J = 1,N
      DO 60  I = 1,N
      II = I + N
      SUM = 0.0D0
      DO 50  K = 1,N
   50 SUM = SUM + X(II,K) * OUTPUT(K,J)
   60 AR(I) = SUM
      DO 70  M = 1,N
   70 OUTPUT(M,J) = AR(M)
      RETURN
C
C
C     FORMATS
C
C
  100 FORMAT (10X, 'NAT FREQ (HZ)', 5X, 'ZETA' /)
  110 FORMAT (1X, 'X11 IS SINGULAR')
  125 FORMAT (12X, G10.4, 5X, G10.4)
  140 FORMAT (1X, 'THE MODE SHAPES FOR THE LINEAR QUADRATIC REGULATOR OR
     * KALMAN FILTER')
 8000 FORMAT (1X, 'HAMILTONIAN MATRIX')
 8002 FORMAT (1H0 / 1X, 'EIGENVALUES OF REGULATOR OR FILTER IN FN/ZETA F
     *ORM')
      END
      SUBROUTINE SCALEA (A, TS, N2, IOP1, N2MAX)
C
C     ******************************************************************
C
C     SUBROUTINE SCALEA TRANSFORMS N2 BY N2 MATRIX A USING DIAGONAL
C     MATRIX TS SO THAT THE NORM OF A IS MINIMIZED. THE RESULTING SCALED
C     MATRIX IS STORED IN A. IF SCALEA FINDS A TO BE REDUCIBLE, IER IS
C     SET TO 1.  SCALEA DOES NOT CALL ANY SUBROUTINES.  SCALET IS CALLED
C     BY SUBROUTINES CONDI, EIGEN, AND RICSS.
C
C     INPUTS:
C
C              A       MATRIX TO BE SCALED (N2,N2)
C              N2      ACTUAL SIZE OF MATRIX A
C              IOP1    PRINT OPTION; 0 NO PRINT, 1 PRINT
C              N2MAX   MAXIMUM SIZE OF N2
C
C     OUTPUTS:
C
C              A       INPUT MATRIX IN SCALED FORM (N2,N2)
C              TS      VECTOR OF DIAGONAL ELEMENTS OF DIAGONAL SCALING
C                      MATRIX (N2)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /ERRS/  IER
      DIMENSION  A(N2MAX,1), TS(1)
C
C
C
C
      EPS = .1D0
      IER = 0
      CONTINUE
      DO 10  I = 1,N2
   10 TS(I) = 1.0
   20 K = 0
      FLAG = 1.0
   30 K = K + 1
      YNUM = 0.0D0
      XDEN = 0.0D0
      DO 40  I = 1,N2
      IF (I .EQ. K)  GO TO 40
      YNUM = YNUM + A(I,K) * A(I,K)
      XDEN = XDEN + A(K,I) * A(K,I)
   40 CONTINUE
      IF (XDEN .EQ. 0.0D0)  GO TO 125
      IF (YNUM .EQ. 0.0D0)  GO TO 125
      SD = YNUM / XDEN
      SD = SD ** .25
      IF (K .EQ. N2)  GO TO 60
      DO 50  J = 1,N2
      DO 50  I = 1,N2
      IF (I .NE. K .AND. J .NE. K)  GO TO 50
      IF (I .EQ. K .AND. J .EQ. K)  GO TO 50
      IF (I .NE. K .AND. J .EQ. K)  A(I,J) = A(I,J) / SD
      IF (I .EQ. K .AND. J .NE. K)  A(I,J) = A(I,J) * SD
   50 CONTINUE
      TS(K) = TS(K) * SD
      GO TO 90
   60 CONTINUE
      DO 70  J = 1,N2
      DO 70  I = 1,N2
      IF (I .NE. K .AND. J .NE. K)  GO TO 70
      IF (I .EQ. K .AND. J .EQ. K)  GO TO 70
      IF (I .NE. K .AND. J .EQ. K)  A(I,J) = A(I,J) / SD
      IF (I .EQ. K .AND. J .NE. K)  A(I,J) = A(I,J) * SD
   70 CONTINUE
      NN2 = N2 - 1
      DO 80  I = 1,NN2
   80 TS(I) = TS(I) / SD
   90 CONTINUE
C
C     IF TS HAS NOT CHANGED BY MORE THAN 100*EPS PERCENT,
C     SCALING IS COMPLETE.
C
      EP1 = EPS + 1.0D0
      EM1 =  - EPS + 1.0D0
      IF (SD .LT. EP1 .AND. SD .GT. EM1)  GO TO 100
      FLAG = 0.0
  100 IF (K .LT. N2)  GO TO 30
      IF (FLAG .EQ. 1.0)  GO TO 110
      GO TO 20
  110 DO 120  I = 1,N2
  120 TS(I) = 1.0 / TS(I)
      IF (IOP1 .EQ. 0)  RETURN
      WRITE (6,130)
      WRITE (6,140)  (TS(I),  I = 1,N2)
      RETURN
  125 WRITE (2,150)
      WRITE (6,150)
      IER = 1
      RETURN
C
C
C     FORMATS
C
C
  130 FORMAT (1X, 'TS, SCALING TRANSFORMATION MATRIX ELEMENTS')
  140 FORMAT (1X, 1P10E12.3, / 3X, 1P10E12.3)
  150 FORMAT (1X, '**** MATRIX IS FOUND TO BE REDUCIBLE ****')
      END
      SUBROUTINE STP (EX1, EX2, B, C, DOUT, IOMTX, AMPIN, DT, TIME,
     * TYOUT, XNEW, XOLD, ANR, TTIT, TTOP, TYTIT, IEXT, N, NIN, NOUT,
     * ITRMX, NMAX, NINMAX, NOUTMX, ITRMXX, IP, NAME, IONPLT)
C
C     ******************************************************************
C
C     SUBROUTINE STP COMPUTES MULTIPLE STEP RESPONSES OF THE SYSTEM
C           XDOT=A*X+B*U; TYOUT=C*X+DOUT*U
C     BY SOLVING THE DIFFERENCE EQ.
C           XNEW=EX1*XOLD + EX2*B*AMPIN(L)
C     THIS SUBROUTINE REQUIRES THAT THE STATE TRANSITION MATRIX,
C     EXP(A*DT), AND ITS INTEGRAL FROM TIME=0 TO TIME=DT, BE SUPPLIED AS
C     INPUT MATRICES 'EX1' AND 'EX2'.  DESIRED INPUT STEP MAGNITUDES ARE
C     SUPPLIED AS VECTOR 'AMPIN' AND THE DESIRED STEP INPUT-OUTPUT
C     RESPONSE COMBINATIONS ARE SELECTED BY APPROPRIATELY DEFINING
C     ELEMENTS OF THE MATRIX 'IOMTX'.  STP CALLS PLOTTING SUBROUTINES
C     ONLY.  STP IS CALLED BY SUBROUTINE AES600.
C
C     INPUTS:
C
C              EX1     STATE TRANSITION, EXP(A*DT), MATRIX (N,N)
C              EX2     INTEGRAL OF THE STATE TRANSITION MATRIX FROM
C                      TIME=0 TO TIME=DT (N,N)
C              B       (CONTINUOUS) SYSTEM INPUT MATRIX (N,NIN)
C              C       SYSTEM OUTPUT MATRIX (NOUT,N)
C              DOUT    SYSTEM INPUT/OUTPUT FEEDTHRU MATRIX (NOUT,NIN)
C              IOMTX   MATRIX OF ZEROES AND ONES (NIN,NOUT).
C                      ONES ARE PLACED IN SELECTED MATRIX POSITIONS TO
C                      INDICATE THE STEP RESPONSES DESIRED.  THE FIRST
C                      INDEX IS 'INPUT', THE SECOND IS 'OUTPUT'.  THUS
C                      SUBROUTINE STP MAY CALCULATE AS MANY AS NIN*NOUT
C                      STEP RESPONSES.
C              AMPIN   VECTOR OF INPUT STEP AMPLITUDES (NIN)
C              DT      TIME STEP
C              TTIT    PLOT TITLE (12)
C              TTOP    PLOT TITLE (12)
C              TYTIT   Y AXIS TITLE (4)
C              N       ACTUAL SIZE OF STATE TRANSITION MATRIX
C              NIN     ACTUAL NUMBER OF POSSIBLE INPUTS
C              NOUT    ACTUAL NUMBER OF POSSIBLE OUTPUTS
C              ITRMX   NUMBER OF DESIRED TIME RESPONSE POINTS
C              NMAX    MAXIMUM SIZE OF N
C              NINMAX  MAXIMUM SIZE OF NIN
C              NOUTMX  MAXIMUM SIZE OF NOUT
C              ITRMXX  MAXIMUM ALLOWABLE VALUE OF ITRMX
C              IP      PLOT ENTITY INDEX (USED BY PLOTSUBS ONLY)
C                      INCREASES BY ONE FOR EACH FRAME
C              NAME    NAME OF PLOT DATASET (9) (USED BY PLOTSUBS ONLY)
C                      (PARTITIONED DATASET THAT HOLDS PLOT ENTITIES)
C              IONPLT  0, IF OFFLINE PLOTS
C                      1, IF ONLINE PLOTS
C
C     OUTPUTS:
C
C              TIME    VECTOR OF TIME POINTS (ITRMXX)
C                      (SINGLE PRECISION)
C              TYOUT   MATRIX OF OUTPUT TRANSIENT RESPONSES FOR ANY
C                      ONE SPECIFIC INPUT STEP (ITRMXX,NOUT)
C                      (SINGLE PRECISION)
C              IP      PLOT ENTITY INDEX (USED BY PLOTSUBS ONLY)
C                      INCREASES BY ONE FOR EACH FRAME
C
C     TEMPORARY STORAGE:
C
C              XNEW    VECTOR (N)
C              XOLD    VECTOR (N)
C              ANR     VECTOR (N)
C              IEXT    INTEGER VECTOR (N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-S,U-Z)
      INTEGER*2 INPTS
      LOGICAL*1 IX / .TRUE. /
      LOGICAL*1 IY / .FALSE. /
      COMMON /PLTLEG/ TRUN(4), TDAT(5)
      COMMON /TITLES/ T1(15), T2(15), TNUM(50), T3(15), T4(15), T5(15),
     *T6(15), T7(15), T8(15), T9(15), T10(15), TB1(15), TB2(15), TB3(15)
      DIMENSION B(NMAX,1), C(NOUTMX,1), DOUT(NOUTMX,1), EX1(NMAX,1),
     * EX2(NMAX,1), ANR(1), XOLD(1), XNEW(1), AMPIN(1), IOMTX(NINMAX,1),
     * IEXT(1)
      DIMENSION  TYOUT(ITRMXX,1), TIME(1), TTIT(1), TAMPIN(2), TTOP(1),
     * TYTIT(1), TAMPL(3), TNARR(2), TVARSX(7), TVARSY(7), NAME(9),
     * IVARS(7)
      DATA TAMPL / 'AMPL', 'ITUD', 'E = ' /
C
C
C
C     CALCULATE RESPONSE FOR L'TH INPUT AND K'TH OUTPUT,
C     AS DETERMINED BY IOMTX
C
      INPTS = ITRMX
      TVARSX(1) = 7.0
      TVARSY(1) = 7.0
      TVARSX(2) = 5.0
      TVARSY(2) = 7.0
      TVARSX(3) = 0.0
      TVARSY(3) = 90.0
      TVARSX(6) = 10.0
      TVARSY(6) = 10.0
      TVARSX(7) = 2.0
      TVARSY(7) = 2.0
      DO 20  I = 1,ITRMX
      AI = I
   20 TIME(I) = (AI - 1.0D0) * DT
      IVARS(1) = 7
      IVARS(2) = ITRMX
      DO 900  L = 1,NIN
      TTOP(10) = TNUM(L)
      DO 820  I = 1,N
      ANR(I) = 0.0D0
      DO 820  KK = 1,N
  820 ANR(I) = ANR(I) + EX2(I,KK) * B(KK,L) * AMPIN(L)
      KX = 0
      DO 850  K = 1,NOUT
      IF (IOMTX(L,K) .EQ. 0)  GO TO 850
      KX = KX + 1
      DO 800  I = 1,N
      XNEW(I) = 0.0D0
  800 XOLD(I) = 0.0D0
C
C     MAIN LOOP FOR COMPUTING OUTPUT RESPONSE
C
      DO 840  IK = 1,ITRMX
      IF (IK .NE. 1)  GO TO 822
      TYOUT(IK,KX) = DOUT(K,L) * AMPIN(L)
      GO TO 840
  822 CONTINUE
      DO 825  I = 1,N
      XNEW(I) = ANR(I)
      DO 825  KK = 1,N
  825 XNEW(I) = XNEW(I) + EX1(I,KK) * XOLD(KK)
      SUM = DOUT(K,L) * AMPIN(L)
      DO 835  I = 1,N
      XOLD(I) = XNEW(I)
      SUM = C(K,I) * XNEW(I) + SUM
  835 TYOUT(IK,KX) = SUM
  840 CONTINUE
  850 CONTINUE
      IF (KX .EQ. 0)  RETURN
C
C     WRITE OUT RESULTS FOR THE L'TH INPUT AND ALL DESIRED OUTPUTS
C
      WRITE (6,110)  L, AMPIN(L)
      WRITE (6,120)
      ICOL = 0
      DO 50  J = 1,NOUT
   50 ICOL = ICOL + IOMTX(L,J)
      LX = 1
      LXX = 9
      I = 0
      DO 18  J = 1,NOUT
      IF (IOMTX(L,J) .EQ. 0)  GO TO 18
      I = I + 1
      IEXT(I) = J
   18 CONTINUE
    1 IF (ICOL .LT. LXX)  LXX = ICOL
      WRITE (6,4)
      IF ((LXX - LX) .EQ. 8)  WRITE (6,130)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 7)  WRITE (6,131)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 6)  WRITE (6,132)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 5)  WRITE (6,133)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 4)  WRITE (6,134)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 3)  WRITE (6,135)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 2)  WRITE (6,136)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 1)  WRITE (6,137)  (IEXT(I),  I=LX,LXX)
      IF ((LXX - LX) .EQ. 0)  WRITE (6,138)  (IEXT(I),  I=LX,LXX)
      DO 10  I = 1,ITRMX
      WRITE (6,500)  TIME(I), (TYOUT(I,J),  J = LX,LXX)
   10 CONTINUE
      WRITE (6,4)
      IF (ICOL .EQ. LXX)  GO TO 860
      LX = LX + 9
      LXX = LXX + 9
      GO TO 1
  860 CONTINUE
      DO 870  J = 1,ICOL
      IXX = IEXT(J)
      TYTIT(3) = TNUM(IXX)
      IP = IP + 2
      CALL BEGID(IP)
      IP1 = IP - 1
      CALL BEGID (IP1)
      CALL SCLBAK (IX, INPTS, TIME, TNARR)
      CALL GINTVL (TNARR(1), TNARR(2), 10, 0, TVARSX(4), TVARSX(5))
      CALL SCLBAK (IY, INPTS, TYOUT(1,J), TNARR)
      CALL GINTVL (TNARR(1), TNARR(2), 10, 0, TVARSY(4), TVARSY(5))
      CALL XAXIS (1.0, 1.0, TVARSX)
      CALL YAXIS (1.0, 1.0, TVARSY)
      CALL SCISS (3)
      CALL GPLOT (TIME, TYOUT(1,J), IVARS)
      CALL TITLE (3, 16, 10, TYTIT)
      CALL TITLE (4, 4, 10, 'TIME')
      CALL ENDID(IP1, 3, NAME)
      TAMP = AMPIN(L)
      CALL NUMBER (4, TAMP, 8, 2, TAMPIN)
      CALL CHARS (48, TTIT, 0.0, 1.2, 8.8, 10)
      CALL CHARS (44, TTOP, 0.0, 1.2, 8.6, 10)
      CALL CHARS (12, TAMPL, 0.0, 2.7, 8.4, 10)
      CALL CHARS (8, TAMPIN, 0.0, 4.1, 8.4, 10)
      CALL CHARS (20, TDAT, 0.0, 4.0, 8.2, -10)
      CALL CHARS (16, TRUN, 0.0, 4.0, 8.0, -10)
      CALL ENDID (IP, -1, NAME)
      CALL DISPLA (1)
      IF (IONPLT .EQ. 1)  PAUSE
  870 CONTINUE
  900 CONTINUE
      RETURN
C
C
C     FORMATS
C
C
    4 FORMAT (1H0)
  110 FORMAT (1X, 'STEP RESPONSES FOR INPUT VARIABLE NO. ', I3, ' WITH A
     *N AMPLITUDE OF ', G10.4 //)
  120 FORMAT (25X, 'AMPLITUDES OF RESPONSE VARIABLES')
  130 FORMAT (2X, 'TIME', 5X, 9(1X, 'VARIABLE', 1X, I2))
  131 FORMAT (2X, 'TIME', 5X, 8(1X, 'VARIABLE', 1X, I2))
  132 FORMAT (2X, 'TIME', 5X, 7(1X, 'VARIABLE', 1X, I2))
  133 FORMAT (2X, 'TIME', 5X, 6(1X, 'VARIABLE', 1X, I2))
  134 FORMAT (2X, 'TIME', 5X, 5(1X, 'VARIABLE', 1X, I2))
  135 FORMAT (2X, 'TIME', 5X, 4(1X, 'VARIABLE', 1X, I2))
  136 FORMAT (2X, 'TIME', 5X, 3(1X, 'VARIABLE', 1X, I2))
  137 FORMAT (2X, 'TIME', 5X, 2(1X, 'VARIABLE', 1X, I2))
  138 FORMAT (2X, 'TIME', 5X, 1X, 'VARIABLE', 1X, I2)
  500 FORMAT (1X, G10.4, 9G12.4)
      END
      SUBROUTINE UNRML (KC, KE, KFF, PP, NC, NM, N, NCMAX, NMAX, FL34)
C
C     ******************************************************************
C
C     SUBROUTINE UNRML IS USED TO CONVERT NORMALIZED KC, KE, KFF, & PP
C     MATRICES TO UN-NORMALIZED FORM.  NORMALIZATION VECTOR INFORMATION
C     IS FED IN THRU COMMON 'NORMS' OR IF NECESSARY, READ IN OFF UNIT 34
C     AS NAMELIST NRMS.  IF FL34 IS .TRUE., IT MEANS THAT NRMS HAS
C     ALREADY BEEN READ IN BY SUBROUTINE NRML & THUS IT SHOULDN'T BE
C     READ IN HERE.  UNRML CALLS SUBROUTINE MATPRT.  UNRML IS CALLED BY
C     SUBROUTINE AES400.
C
C     INPUTS:
C
C              KC      NORMALIZED CONTROL GAIN MATRIX (NC,N)
C              KE      NORMALIZED KALMAN FILTER GAIN MATRIX (N,NM)
C              KFF     NORMALIZED FEED FORWARD GAIN MATRIX FOR
C                      NON-ZERO SET POINT REGULATOR (NC,NC)
C              PP      NORMALIZED KALMAN FILTER ERROR COVARIANCE
C                      MATRIX (N,N)
C              NC      ACTUAL NUMBER OF CONTROL INPUTS
C              NM      ACTUAL NUMBER OF MEASUREMENTS
C              N       ACTUAL NUMBER OF STATES
C              NCMAX   MAXIMUM SIZE OF NC
C              NMAX    MAXIMUM SIZE OF N
C              FL34    LOGICAL VARIABLE, ON INPUT
C                      TRUE, NORMALIZATION VECTOR INFORMATION
C                      (NAMELIST NRMS) HAS ALREADY BEEN READ IN
C                      FALSE, NORMALIZATION VECTOR INFORMATION
C                      (NAMELIST NRMS) NEEDS TO BE READ IN
C
C     OUTPUTS:
C
C              KC      UN-NORMALIZED CONTROL GAIN MATRIX (NC,N)
C              KE      UN-NORMALIZED KALMAN FILTER GAIN MATRIX (N,NM)
C              KFF     UN-NORMALIZED FEED FORWARD GAIN MATRIX FOR
C                      NON-ZERO SET POINT REGULATOR (NC,NC)
C              PP      UN-NORMALIZED KALMAN FILTER ERROR COVARIANCE
C                      MATRIX (N,N)
C              FL34    LOGICAL VARIABLE, ON OUTPUT SET TO
C                      TRUE IF NORMALIZATION VECTOR INFORMATION
C                      (NAMELIST NRMS) HAS BEEN READ IN
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 KC, KE, KFF
      LOGICAL FL34
      COMMON /NORMS/  SCX(50), SCU(5), SCY(50), SCZ(5), SCYSP(5)
      DIMENSION KC(NCMAX,1), KE(NMAX,1), KFF(NCMAX,1), PP(NMAX,1)
      NAMELIST /NRMS/  SCX, SCU, SCY, SCZ, SCYSP
C
C
C
      IF (FL34)  GO TO 10
      DO 5  K = 1,N
    5 SCX(K) = 1.0D0
      DO 7  K = 1,NC
      SCYSP(K) = 1.0D0
    7 SCU(K) = 1.0D0
      DO 8  K = 1,NO
    8 SCY(K) = 1.0D0
      DO 9  K = 1,NM
    9 SCZ(K) = 1.0D0
      WRITE (2,100)
      PAUSE
      READ (34,NRMS)
      FL34 = .TRUE.
   10 CONTINUE
      WRITE (2,60)
      WRITE (6,60)
      WRITE (2,NRMS)
      WRITE (6,NRMS)
      DO 50  I = 1,N
      DO 20  J = 1,NC
   20 KC(J,I) = KC(J,I) * SCU(J) / SCX(I)
      DO 30  J = 1,NM
   30 KE(I,J) = KE(I,J) * SCX(I) / SCZ(J)
      DO 50  J = 1,N
   50 PP(I,J) = PP(I,J) * SCX(I) * SCX(J)
      DO 55  J = 1,NC
      DO 55  I = 1,NC
   55 KFF(I,J) = KFF(I,J) * SCU(I) / SCYSP(J)
      RETURN
C
C
C     FORMATS
C
C
   60 FORMAT (1H0 / 1X, 'NORMALIZING FACTORS')
  100 FORMAT (1X, 'IF NOT ALREADY DONE, DDEF DATASET CONTAINING NAMELIST
     * ''NRMS'' TO UNIT 34')
      END
      SUBROUTINE UZR901
      RETURN
      END
      SUBROUTINE UZR902
      RETURN
      END
      SUBROUTINE UZR903
      RETURN
      END
      SUBROUTINE UZR904
      RETURN
      END
      SUBROUTINE ZEROES (AA, BB, CC, DD, CONST, ANR, ANI, N, II, JJ, L,
     * AR, TS, BR, LWV, MWV, ZERMAX, IA, IB, IBL, IC, S, SS, NMAX,
     * NOMAX)
C
C     ******************************************************************
C
C     SUBROUTINE ZEROES FINDS THE NUMERATOR ZEROES OF THE TRANSFER
C     FUNCTION   Y(II) / U(JJ) = CC * ((S * I - A ) ** -1 ) * BB
C     II DENOTES DESIRED COMPONENT OF OUTPUT VECTOR
C     JJ DENOTES DESIRED COMPONENT OF INPUT VECTOR
C     ZEROES CALLS SUBROUTINES CONDI, EIGQR, HSBG, AND ARRAY.  ZEROES IS
C     CALLED BY SUBROUTINE AES700.
C
C     INPUTS:
C
C              AA      SYSTEM MATRIX (N,N)
C              BB      INPUT MATRIX (N,NUMBER OF POSSIBLE INPUTS)
C              CC      OUTPUT MATRIX (NUMBER OF POSSIBLE OUTPUTS,N)
C              DD      CONSTANT
C              CONST   ITERATION CONSTANT
C              N       ACTUAL SIZE OF MATRIX AA
C              II      OUTPUT COMPONENT
C              JJ      INPUT COMPONENT
C              NMAX    MAXIMUM SIZE OF N
C              NOMAX   MAXIMUM NUMBER OF OUTPUTS
C
C     OUTPUTS:
C
C              ANR     VECTOR OF REAL PARTS OF EIGENVALUES (N)
C              ANI     VECTOR OF IMAGINARY PARTS OF EIGENVALUES (N)
C              L       NUMBER OF ZEROES
C              ZERMAX  MAXIMUM EXPECTED VALUE OF TRANSFER FUNCTION
C                      ZEROES
C
C     TEMPORARY STORAGE:
C
C              AR      MATRIX (N,N)
C              TS      MATRIX (N,N)
C              BR      VECTOR (N)
C              LWV     INTEGER VECTOR (2 X N)
C              MWV     INTEGER VECTOR (2 X N)
C              IA      INTEGER VECTOR (2 X N)
C              IB      INTEGER VECTOR (2 X N)
C              IBL     INTEGER VECTOR (2 X N)
C              IC      INTEGER VECTOR (2 X N)
C              S       MATRIX (N,N)
C              SS      MATRIX (N,N)
C
C     ******************************************************************
C
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL  ILAMB
      DIMENSION  AA(NMAX,1), BB(NMAX,1), CC(NOMAX,1), ANR(1), ANI(1),
     * BR(1), AR(NMAX,1), TS(NMAX,1), LWV(1), MWV(1), IA(1), IB(1),
     * IBL(1), IC(1), S(NMAX,1), SS(NMAX,1)
C
C
C
      ABS(X) = DABS(X)
      SQRT(X) = DSQRT(X)
C
      EMAX = 0.0D0
      IMAX = 0
C
C     FIND MAX. ELEMENT IN IITH ROW OF CC. ITS POSITION IS IMAX.
C
      DO 5  I = 1,N
      IF (ABS(CC(II,I)) .LE. EMAX)  GO TO 5
      EMAX = ABS(CC(II,I))
      IMAX = I
    5 CONTINUE
      IF (DD .EQ. 0.0D0)  GO TO 201
      DO 202  J = 1,N
      DO 202  I = 1,N
  202 AR(I,J) = AA(I,J)
      IF (IMAX .EQ. 0)  GO TO 45
      DO 203  J = 1,N
      DO 203  I = 1,N
      SS(I,J) = BB(I,JJ) * CC(II,J)
      SS(I,J) = - SS(I,J) / DD
  203 AR(I,J) = AR(I,J) + SS(I,J)
      GO TO 45
  201 IF (IMAX .GT. 0)  GO TO 10
      WRITE (6,7)  II,JJ
      WRITE (2,7)  II,JJ
      PAUSE
      RETURN
C
C     DOES MAX. ELEMENT OCCUR BEFORE (N+1)/2 TH POSITION.  IF SO ILAMB
C     IS FALSE
C
   10 NLIM = (N + 1) / 2
      ILAMB = .TRUE.
      IF (IMAX .LE. NLIM)  ILAMB = .FALSE.
C     FORM AR TO AVOID DESTROYING AA
      DO 12  J = 1,N
      DO 12  I = 1,N
   12 AR(I,J) = AA(I,J)
C     PREMULT T BY AR  CHANGES IMAX ROW ONLY
      DO 17  I = 1,N
      SUM = 0.
      DO 15  J = 1,N
   15 SUM = SUM + CC(II,J) * AR(J,I)
   17 AR(IMAX,I) = SUM
      PIVOT = 1. / CC(II,IMAX)
C     POST MULT BY T INVERSE
      DO 1034  J = 1,N
      IF (J .EQ. IMAX)  GO TO 1034
      DO 1033  I = 1,N
 1033 AR(I,J) = AR(I,J) - AR(I,IMAX) * CC(II,J) * PIVOT
 1034 CONTINUE
C     FORM BR TO AVOID DESTROYING BB
      DO 195  I = 1,N
      IF (I .EQ. IMAX)  GO TO 193
      SUM = BB(I,JJ)
      GO TO 195
  193 SUM = 0.
      DO 194  J = 1,N
  194 SUM = SUM + CC(II,J) * BB(J,JJ)
  195 BR(I) = SUM
      DO 25  I = 1,N
   25 AR(I,IMAX) = BR(I)
C
C     SUM ABSOLUTE VALUES OF ELEMENTS OF BR AND ALSO OF THE IMAXTH
C     COLUMN OF AR, THE TRANSFORMED AA MATRIX
C
      ANUM = 0.0
      ADEN = 0.0
      DO 20  I = 1,N
      ADEN = ADEN + ABS(BR(I))
      DO 20  J = 1,N
      IF (J .EQ. IMAX)  GO TO 20
      ANUM = ANUM + ABS(AR(I,J))
   20 CONTINUE
      ENEF = ANUM / ADEN
      DO 756  J = 1,N
      DO 756  I = 1,N
  756 TS(I,J) = AR(I,J)
      IFIN = 0
 1000 CONTINUE
      DO 757  J = 1,N
      DO 757  I = 1,N
  757 AR(I,J) = TS(I,J)
      AKSTAR = CONST * ENEF
      IF (AKSTAR .LE. 1.0E16)  GO TO 58
      RETURN
   58 IF (ILAMB)  GO TO 35
C
C     IF ILAMB = FALSE, MULTIPLY IMAXTH ROW BY AKSTAR.
C
      DO 30  J = 1,N
   30 AR(IMAX,J) = AR(IMAX,J) * AKSTAR
      GO TO 45
C
C     IF ILAMB = TRUE, MULTIPLY IMAXTH COLUMN BY AKSTAR.
C
   35 DO 40  I = 1,N
   40 AR(I,IMAX) = AR(I,IMAX) * AKSTAR
C
C     CONDITION AND HESSENBURG TRANSFORM AR AND THEN FIND ITS EIGENVALUE
C
   45 CONTINUE
      CALL CONDI (AR, SS, S, IA, IB, LWV, MWV, IBL, IC, BR, 0, N, NMAX)
      DO 1013  J = 1,N
      DO 1013  I = 1,N
 1013 AR(I,J) = S(I,J)
      CALL ARRAY (2, N, N, NMAX, AR)
      CALL HSBG (N, AR, N)
      CALL ARRAY (1, N, N, NMAX, AR)
      IOP = 0
      CALL EIGQR (AR, N, ANR, ANI, IOP, NMAX)
      DO 1014  I = 1,N
      OMEGAN = SQRT(ANR(I) * ANR(I) + ANI(I) * ANI(I))
      IF (OMEGAN .NE. 0.0D0)  GO TO 1100
      ZETA = 1.
      FN = 0.0D0
      GO TO 1014
 1100 CONTINUE
      ZETA =  - ANR(I) / OMEGAN
      FN = OMEGAN / 6.2832
 1014 CONTINUE
      IF (DD .EQ. 0.0D0)  GO TO 1015
      L = N
      GO TO 638
C
C     CHECK FOR EIGENVALUES TO BE DISCARDED.
C
C
C     IF REAL OR IMAGINARY PART IS VERY LARGE,
C     THE EIGENVALUE IS NOT A ZERO.
C
 1015 MAX = N
      I = 1
      L = 1
   62 IF (ABS(ANR(I)) .GT. ZERMAX)  GO TO 599
      IF (ABS(ANI(I)) .GT. ZERMAX)  GO TO 599
      L = L + 1
      I = I + 1
      IF (I .GT. MAX)  GO TO 70
      GO TO 62
C
C     OVERWRITE DISCARDED ZERO WITH NEXT ZERO AND MOVE THE REST UP
C     ONE LOCATION.
C
  599 MAX1 = MAX - 1
      DO 65  J = I,MAX1
      ANR(J) = ANR(J+1)
   65 ANI(J) = ANI(J+1)
      ANR(MAX) = 0.0
      ANI(MAX) = 0.0
      MAX = MAX1
      IF (I .GT. MAX)  GO TO 70
      GO TO 62
   70 I = I - 1
      L = L - 1
      IF (L .NE. 0)  GO TO 71
      WRITE (6,72)
      RETURN
   71 IF (I .NE. N .OR. L .NE. N)  GO TO 637
      CONST = CONST * 10.0
      GO TO 1000
  637 CONTINUE
      IF (IFIN .EQ. 1)  GO TO 638
      IFIN = 1
      CONST = CONST * 10.0
      GO TO 1000
C
C     L NOW CONTAINS THE NUMBER OF ZEROES
C
  638 WRITE (6,75)  L
      WRITE (6,80)
      WRITE (6,55)  (ANR(I),  I = 1,L)
      WRITE (6,90)
      WRITE (6,55)  (ANI(I),  I = 1,L)
      RETURN
C
C
C     FORMATS
C
C
    7 FORMAT (1X, 'TRANSFER FUNCTION RELATING INPUT ', I3, ' AND OUTPUT
     *', I3, ' IS ZERO' / 1X, 'THE PROGRAM WILL NOW PAUSE: ' / 1X, 'IF Y
     *OU WISH TO STOP, DO SO; ' / 1X, 'IF YOU WISH TO CONTINUE WITH THE
     *NEXT CASE IN YOUR LIST, TYPE GO')
   55 FORMAT (1X, 10G12.5)
   72 FORMAT (1X, 'THERE ARE NO ZEROES')
   75 FORMAT (1X, 'NUMBER OF ZEROES = ', I3)
   80 FORMAT (1X, 'REAL PARTS OF NUMERATOR ZEROES')
   90 FORMAT (1X, 'IMAGINARY PARTS OF NUMERATOR ZEROES')
      END
